home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / dbctrls.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  129.8 KB  |  4,955 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit DBCtrls;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses Windows, SysUtils, Messages, Classes, Controls, Forms,
  17.      Graphics, Menus, StdCtrls, ExtCtrls, Mask, Buttons, ComCtrls, Db;
  18.  
  19. type
  20.  
  21. { TFieldDataLink }
  22.  
  23.   TFieldDataLink = class(TDataLink)
  24.   private
  25.     FField: TField;
  26.     FFieldName: string;
  27.     FControl: TControl;
  28.     FEditing: Boolean;
  29.     FModified: Boolean;
  30.     FOnDataChange: TNotifyEvent;
  31.     FOnEditingChange: TNotifyEvent;
  32.     FOnUpdateData: TNotifyEvent;
  33.     FOnActiveChange: TNotifyEvent;
  34.     function GetCanModify: Boolean;
  35.     procedure SetEditing(Value: Boolean);
  36.     procedure SetField(Value: TField);
  37.     procedure SetFieldName(const Value: string);
  38.     procedure UpdateField;
  39.   protected
  40.     procedure ActiveChanged; override;
  41.     procedure EditingChanged; override;
  42.     procedure FocusControl(Field: TFieldRef); override;
  43.     procedure LayoutChanged; override;
  44.     procedure RecordChanged(Field: TField); override;
  45.     procedure UpdateData; override;
  46.   public
  47.     constructor Create(AControl: TControl);
  48.     function Edit: Boolean;
  49.     procedure Modified;
  50.     procedure Reset;
  51.     property CanModify: Boolean read GetCanModify;
  52.     property Control: TControl read FControl write FControl;
  53.     property Editing: Boolean read FEditing;
  54.     property Field: TField read FField;
  55.     property FieldName: string read FFieldName write SetFieldName;
  56.     property OnDataChange: TNotifyEvent read FOnDataChange write FOnDataChange;
  57.     property OnEditingChange: TNotifyEvent read FOnEditingChange write FOnEditingChange;
  58.     property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
  59.     property OnActiveChange: TNotifyEvent read FOnActiveChange write FOnActiveChange;
  60.   end;
  61.  
  62. { TPaintControl }
  63.  
  64.   TPaintControl = class
  65.   private
  66.     FOwner: TWinControl;
  67.     FClassName: string;
  68.     FHandle: HWnd;
  69.     FObjectInstance: Pointer;
  70.     FDefWindowProc: Pointer;
  71.     FCtl3dButton: Boolean;
  72.     function GetHandle: HWnd;
  73.     procedure SetCtl3DButton(Value: Boolean);
  74.     procedure WndProc(var Message: TMessage);
  75.   public
  76.     constructor Create(AOwner: TWinControl; const ClassName: string);
  77.     destructor Destroy; override;
  78.     procedure DestroyHandle;
  79.     property Ctl3DButton: Boolean read FCtl3dButton write SetCtl3dButton;
  80.     property Handle: HWnd read GetHandle;
  81.   end;
  82.  
  83. { TDBEdit }
  84.  
  85.   TDBEdit = class(TCustomMaskEdit)
  86.   private
  87.     FDataLink: TFieldDataLink;
  88.     FCanvas: TControlCanvas;
  89.     FAlignment: TAlignment;
  90.     FFocused: Boolean;
  91.     procedure DataChange(Sender: TObject);
  92.     procedure EditingChange(Sender: TObject);
  93.     function GetDataField: string;
  94.     function GetDataSource: TDataSource;
  95.     function GetField: TField;
  96.     function GetReadOnly: Boolean;
  97.     function GetTextMargins: TPoint;
  98.     procedure SetDataField(const Value: string);
  99.     procedure SetDataSource(Value: TDataSource);
  100.     procedure SetFocused(Value: Boolean);
  101.     procedure SetReadOnly(Value: Boolean);
  102.     procedure UpdateData(Sender: TObject);
  103.     procedure WMCut(var Message: TMessage); message WM_CUT;
  104.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  105.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  106.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  107.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  108.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  109.   protected
  110.     procedure Change; override;
  111.     function EditCanModify: Boolean; override;
  112.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  113.     procedure KeyPress(var Key: Char); override;
  114.     procedure Notification(AComponent: TComponent;
  115.       Operation: TOperation); override;
  116.     procedure Reset; override;
  117.   public
  118.     constructor Create(AOwner: TComponent); override;
  119.     destructor Destroy; override;
  120.     property Field: TField read GetField;
  121.   published
  122.     property AutoSelect;
  123.     property AutoSize;
  124.     property BorderStyle;
  125.     property CharCase;
  126.     property Color;
  127.     property Ctl3D;
  128.     property DataField: string read GetDataField write SetDataField;
  129.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  130.     property DragCursor;
  131.     property DragMode;
  132.     property Enabled;
  133.     property Font;
  134.     property ImeMode;
  135.     property ImeName;
  136.     property MaxLength;
  137.     property ParentColor;
  138.     property ParentCtl3D;
  139.     property ParentFont;
  140.     property ParentShowHint;
  141.     property PasswordChar;
  142.     property PopupMenu;
  143.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  144.     property ShowHint;
  145.     property TabOrder;
  146.     property TabStop;
  147.     property Visible;
  148.     property OnChange;
  149.     property OnClick;
  150.     property OnDblClick;
  151.     property OnDragDrop;
  152.     property OnDragOver;
  153.     property OnEndDrag;
  154.     property OnEnter;
  155.     property OnExit;
  156.     property OnKeyDown;
  157.     property OnKeyPress;
  158.     property OnKeyUp;
  159.     property OnMouseDown;
  160.     property OnMouseMove;
  161.     property OnMouseUp;
  162.     property OnStartDrag;
  163.   end;
  164.  
  165. { TDBText }
  166.  
  167.   TDBText = class(TCustomLabel)
  168.   private
  169.     FDataLink: TFieldDataLink;
  170.     procedure DataChange(Sender: TObject);
  171.     function GetDataField: string;
  172.     function GetDataSource: TDataSource;
  173.     function GetField: TField;
  174.     function GetFieldText: string;
  175.     procedure SetDataField(const Value: string);
  176.     procedure SetDataSource(Value: TDataSource);
  177.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  178.   protected
  179.     function GetLabelText: string; override;
  180.     procedure Notification(AComponent: TComponent;
  181.       Operation: TOperation); override;
  182.     procedure SetAutoSize(Value: Boolean); override;
  183.   public
  184.     constructor Create(AOwner: TComponent); override;
  185.     destructor Destroy; override;
  186.     property Field: TField read GetField;
  187.   published
  188.     property Align;
  189.     property Alignment;
  190.     property AutoSize default False;
  191.     property Color;
  192.     property DataField: string read GetDataField write SetDataField;
  193.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  194.     property DragCursor;
  195.     property DragMode;
  196.     property Enabled;
  197.     property Font;
  198.     property ParentColor;
  199.     property ParentFont;
  200.     property ParentShowHint;
  201.     property PopupMenu;
  202.     property Transparent;
  203.     property ShowHint;
  204.     property Visible;
  205.     property WordWrap;
  206.     property OnClick;
  207.     property OnDblClick;
  208.     property OnDragDrop;
  209.     property OnDragOver;
  210.     property OnEndDrag;
  211.     property OnMouseDown;
  212.     property OnMouseMove;
  213.     property OnMouseUp;
  214.     property OnStartDrag;
  215.   end;
  216.  
  217. { TDBCheckBox }
  218.  
  219.   TDBCheckBox = class(TCustomCheckBox)
  220.   private
  221.     FDataLink: TFieldDataLink;
  222.     FValueCheck: string;
  223.     FValueUncheck: string;
  224.     FPaintControl: TPaintControl;
  225.     procedure DataChange(Sender: TObject);
  226.     function GetDataField: string;
  227.     function GetDataSource: TDataSource;
  228.     function GetField: TField;
  229.     function GetFieldState: TCheckBoxState;
  230.     function GetReadOnly: Boolean;
  231.     procedure SetDataField(const Value: string);
  232.     procedure SetDataSource(Value: TDataSource);
  233.     procedure SetReadOnly(Value: Boolean);
  234.     procedure SetValueCheck(const Value: string);
  235.     procedure SetValueUncheck(const Value: string);
  236.     procedure UpdateData(Sender: TObject);
  237.     function ValueMatch(const ValueList, Value: string): Boolean;
  238.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  239.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  240.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  241.   protected
  242.     procedure Toggle; override;
  243.     procedure KeyPress(var Key: Char); override;
  244.     procedure Notification(AComponent: TComponent;
  245.       Operation: TOperation); override;
  246.     procedure WndProc(var Message: TMessage); override;
  247.   public
  248.     constructor Create(AOwner: TComponent); override;
  249.     destructor Destroy; override;
  250.     property Checked;
  251.     property Field: TField read GetField;
  252.     property State;
  253.   published
  254.     property Alignment;
  255.     property AllowGrayed;
  256.     property Caption;
  257.     property Color;
  258.     property Ctl3D;
  259.     property DataField: string read GetDataField write SetDataField;
  260.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  261.     property DragCursor;
  262.     property DragMode;
  263.     property Enabled;
  264.     property Font;
  265.     property ParentColor;
  266.     property ParentCtl3D;
  267.     property ParentFont;
  268.     property ParentShowHint;
  269.     property PopupMenu;
  270.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  271.     property ShowHint;
  272.     property TabOrder;
  273.     property TabStop;
  274.     property ValueChecked: string read FValueCheck write SetValueCheck;
  275.     property ValueUnchecked: string read FValueUncheck write SetValueUncheck;
  276.     property Visible;
  277.     property OnClick;
  278.     property OnDragDrop;
  279.     property OnDragOver;
  280.     property OnEndDrag;
  281.     property OnEnter;
  282.     property OnExit;
  283.     property OnKeyDown;
  284.     property OnKeyPress;
  285.     property OnKeyUp;
  286.     property OnMouseDown;
  287.     property OnMouseMove;
  288.     property OnMouseUp;
  289.     property OnStartDrag;
  290.   end;
  291.  
  292. { TDBComboBox }
  293.  
  294.   TDBComboBox = class(TCustomComboBox)
  295.   private
  296.     FDataLink: TFieldDataLink;
  297.     FPaintControl: TPaintControl;
  298.     procedure DataChange(Sender: TObject);
  299.     procedure EditingChange(Sender: TObject);
  300.     function GetComboText: string;
  301.     function GetDataField: string;
  302.     function GetDataSource: TDataSource;
  303.     function GetField: TField;
  304.     function GetReadOnly: Boolean;
  305.     procedure SetComboText(const Value: string);
  306.     procedure SetDataField(const Value: string);
  307.     procedure SetDataSource(Value: TDataSource);
  308.     procedure SetEditReadOnly;
  309.     procedure SetItems(Value: TStrings);
  310.     procedure SetReadOnly(Value: Boolean);
  311.     procedure UpdateData(Sender: TObject);
  312.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  313.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  314.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  315.   protected
  316.     procedure Change; override;
  317.     procedure Click; override;
  318.     procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
  319.       ComboProc: Pointer); override;
  320.     procedure CreateWnd; override;
  321.     procedure DropDown; override;
  322.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  323.     procedure KeyPress(var Key: Char); override;
  324.     procedure Notification(AComponent: TComponent;
  325.       Operation: TOperation); override;
  326.     procedure SetStyle(Value: TComboboxStyle); override;
  327.     procedure WndProc(var Message: TMessage); override;
  328.   public
  329.     constructor Create(AOwner: TComponent); override;
  330.     destructor Destroy; override;
  331.     property Field: TField read GetField;
  332.     property Text;
  333.   published
  334.     property Style; {Must be published before Items}
  335.     property Color;
  336.     property Ctl3D;
  337.     property DataField: string read GetDataField write SetDataField;
  338.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  339.     property DragMode;
  340.     property DragCursor;
  341.     property DropDownCount;
  342.     property Enabled;
  343.     property Font;
  344.     property ImeMode;
  345.     property ImeName;
  346.     property ItemHeight;
  347.     property Items write SetItems;
  348.     property ParentColor;
  349.     property ParentCtl3D;
  350.     property ParentFont;
  351.     property ParentShowHint;
  352.     property PopupMenu;
  353.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  354.     property ShowHint;
  355.     property Sorted;
  356.     property TabOrder;
  357.     property TabStop;
  358.     property Visible;
  359.     property OnChange;
  360.     property OnClick;
  361.     property OnDblClick;
  362.     property OnDragDrop;
  363.     property OnDragOver;
  364.     property OnDrawItem;
  365.     property OnDropDown;
  366.     property OnEndDrag;
  367.     property OnEnter;
  368.     property OnExit;
  369.     property OnKeyDown;
  370.     property OnKeyPress;
  371.     property OnKeyUp;
  372.     property OnMeasureItem;
  373.     property OnStartDrag;
  374.   end;
  375.  
  376. { TDBListBox }
  377.  
  378.   TDBListBox = class(TCustomListBox)
  379.   private
  380.     FDataLink: TFieldDataLink;
  381.     procedure DataChange(Sender: TObject);
  382.     procedure UpdateData(Sender: TObject);
  383.     function GetDataField: string;
  384.     function GetDataSource: TDataSource;
  385.     function GetField: TField;
  386.     function GetReadOnly: Boolean;
  387.     procedure SetDataField(const Value: string);
  388.     procedure SetDataSource(Value: TDataSource);
  389.     procedure SetReadOnly(Value: Boolean);
  390.     procedure SetItems(Value: TStrings);
  391.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  392.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  393.   protected
  394.     procedure Click; override;
  395.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  396.     procedure KeyPress(var Key: Char); override;
  397.     procedure Notification(AComponent: TComponent;
  398.       Operation: TOperation); override;
  399.   public
  400.     constructor Create(AOwner: TComponent); override;
  401.     destructor Destroy; override;
  402.     property Field: TField read GetField;
  403.   published
  404.     property Align;
  405.     property BorderStyle;
  406.     property Color;
  407.     property Ctl3D default True;
  408.     property DataField: string read GetDataField write SetDataField;
  409.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  410.     property DragCursor;
  411.     property DragMode;
  412.     property Enabled;
  413.     property Font;
  414.     property ImeMode;
  415.     property ImeName;
  416.     property IntegralHeight;
  417.     property ItemHeight;
  418.     property Items write SetItems;
  419.     property ParentColor;
  420.     property ParentCtl3D;
  421.     property ParentFont;
  422.     property ParentShowHint;
  423.     property PopupMenu;
  424.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  425.     property ShowHint;
  426.     property Style;
  427.     property TabOrder;
  428.     property TabStop;
  429.     property Visible;
  430.     property OnClick;
  431.     property OnDblClick;
  432.     property OnDragDrop;
  433.     property OnDragOver;
  434.     property OnDrawItem;
  435.     property OnEndDrag;
  436.     property OnEnter;
  437.     property OnExit;
  438.     property OnKeyDown;
  439.     property OnKeyPress;
  440.     property OnKeyUp;
  441.     property OnMeasureItem;
  442.     property OnMouseDown;
  443.     property OnMouseMove;
  444.     property OnMouseUp;
  445.     property OnStartDrag;
  446.   end;
  447.  
  448. { TDBRadioGroup }
  449.  
  450.   TDBRadioGroup = class(TCustomRadioGroup)
  451.   private
  452.     FDataLink: TFieldDataLink;
  453.     FValue: string;
  454.     FValues: TStrings;
  455.     FInSetValue: Boolean;
  456.     FOnChange: TNotifyEvent;
  457.     procedure DataChange(Sender: TObject);
  458.     procedure UpdateData(Sender: TObject);
  459.     function GetDataField: string;
  460.     function GetDataSource: TDataSource;
  461.     function GetField: TField;
  462.     function GetReadOnly: Boolean;
  463.     function GetButtonValue(Index: Integer): string;
  464.     procedure SetDataField(const Value: string);
  465.     procedure SetDataSource(Value: TDataSource);
  466.     procedure SetReadOnly(Value: Boolean);
  467.     procedure SetValue(const Value: string);
  468.     procedure SetItems(Value: TStrings);
  469.     procedure SetValues(Value: TStrings);
  470.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  471.   protected
  472.     procedure Change; dynamic;
  473.     procedure Click; override;
  474.     procedure KeyPress(var Key: Char); override;
  475.     function CanModify: Boolean; override;
  476.     procedure Notification(AComponent: TComponent;
  477.       Operation: TOperation); override;
  478.     property DataLink: TFieldDataLink read FDataLink;
  479.   public
  480.     constructor Create(AOwner: TComponent); override;
  481.     destructor Destroy; override;
  482.     property Field: TField read GetField;
  483.     property ItemIndex;
  484.     property Value: string read FValue write SetValue;
  485.   published
  486.     property Align;
  487.     property Caption;
  488.     property Color;
  489.     property Columns;
  490.     property Ctl3D;
  491.     property DataField: string read GetDataField write SetDataField;
  492.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  493.     property DragCursor;
  494.     property DragMode;
  495.     property Enabled;
  496.     property Font;
  497.     property Items write SetItems;
  498.     property ParentColor;
  499.     property ParentCtl3D;
  500.     property ParentFont;
  501.     property ParentShowHint;
  502.     property PopupMenu;
  503.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  504.     property ShowHint;
  505.     property TabOrder;
  506.     property TabStop;
  507.     property Values: TStrings read FValues write SetValues;
  508.     property Visible;
  509.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  510.     property OnClick;
  511.     property OnDragDrop;
  512.     property OnDragOver;
  513.     property OnEndDrag;
  514.     property OnEnter;
  515.     property OnExit;
  516.     property OnStartDrag;
  517.   end;
  518.  
  519. { TDBMemo }
  520.  
  521.   TDBMemo = class(TCustomMemo)
  522.   private
  523.     FDataLink: TFieldDataLink;
  524.     FAutoDisplay: Boolean;
  525.     FFocused: Boolean;
  526.     FMemoLoaded: Boolean;
  527.     FPaintControl: TPaintControl;
  528.     procedure DataChange(Sender: TObject);
  529.     procedure EditingChange(Sender: TObject);
  530.     function GetDataField: string;
  531.     function GetDataSource: TDataSource;
  532.     function GetField: TField;
  533.     function GetReadOnly: Boolean;
  534.     procedure SetDataField(const Value: string);
  535.     procedure SetDataSource(Value: TDataSource);
  536.     procedure SetReadOnly(Value: Boolean);
  537.     procedure SetAutoDisplay(Value: Boolean);
  538.     procedure SetFocused(Value: Boolean);
  539.     procedure UpdateData(Sender: TObject);
  540.     procedure WMCut(var Message: TMessage); message WM_CUT;
  541.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  542.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  543.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  544.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  545.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  546.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  547.   protected
  548.     procedure Change; override;
  549.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  550.     procedure KeyPress(var Key: Char); override;
  551.     procedure Notification(AComponent: TComponent;
  552.       Operation: TOperation); override;
  553.     procedure WndProc(var Message: TMessage); override;
  554.   public
  555.     constructor Create(AOwner: TComponent); override;
  556.     destructor Destroy; override;
  557.     procedure LoadMemo;
  558.     property Field: TField read GetField;
  559.   published
  560.     property Align;
  561.     property Alignment;
  562.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  563.     property BorderStyle;
  564.     property Color;
  565.     property Ctl3D;
  566.     property DataField: string read GetDataField write SetDataField;
  567.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  568.     property DragCursor;
  569.     property DragMode;
  570.     property Enabled;
  571.     property Font;
  572.     property ImeMode;
  573.     property ImeName;
  574.     property MaxLength;
  575.     property ParentColor;
  576.     property ParentCtl3D;
  577.     property ParentFont;
  578.     property ParentShowHint;
  579.     property PopupMenu;
  580.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  581.     property ScrollBars;
  582.     property ShowHint;
  583.     property TabOrder;
  584.     property TabStop;
  585.     property Visible;
  586.     property WantTabs;
  587.     property WordWrap;
  588.     property OnChange;
  589.     property OnClick;
  590.     property OnDblClick;
  591.     property OnDragDrop;
  592.     property OnDragOver;
  593.     property OnEndDrag;
  594.     property OnEnter;
  595.     property OnExit;
  596.     property OnKeyDown;
  597.     property OnKeyPress;
  598.     property OnKeyUp;
  599.     property OnMouseDown;
  600.     property OnMouseMove;
  601.     property OnMouseUp;
  602.     property OnStartDrag;
  603.   end;
  604.  
  605. { TDBImage }
  606.  
  607.   TDBImage = class(TCustomControl)
  608.   private
  609.     FDataLink: TFieldDataLink;
  610.     FPicture: TPicture;
  611.     FBorderStyle: TBorderStyle;
  612.     FAutoDisplay: Boolean;
  613.     FStretch: Boolean;
  614.     FCenter: Boolean;
  615.     FPictureLoaded: Boolean;
  616.     FQuickDraw: Boolean;
  617.     procedure DataChange(Sender: TObject);
  618.     function GetDataField: string;
  619.     function GetDataSource: TDataSource;
  620.     function GetField: TField;
  621.     function GetReadOnly: Boolean;
  622.     procedure PictureChanged(Sender: TObject);
  623.     procedure SetAutoDisplay(Value: Boolean);
  624.     procedure SetBorderStyle(Value: TBorderStyle);
  625.     procedure SetCenter(Value: Boolean);
  626.     procedure SetDataField(const Value: string);
  627.     procedure SetDataSource(Value: TDataSource);
  628.     procedure SetPicture(Value: TPicture);
  629.     procedure SetReadOnly(Value: Boolean);
  630.     procedure SetStretch(Value: Boolean);
  631.     procedure UpdateData(Sender: TObject);
  632.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  633.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  634.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  635.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  636.     procedure WMCut(var Message: TMessage); message WM_CUT;
  637.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  638.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  639.     procedure WMSize(var Message: TMessage); message WM_SIZE;
  640.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  641.   protected
  642.     procedure CreateParams(var Params: TCreateParams); override;
  643.     function GetPalette: HPALETTE; override;
  644.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  645.     procedure KeyPress(var Key: Char); override;
  646.     procedure Notification(AComponent: TComponent;
  647.       Operation: TOperation); override;
  648.     procedure Paint; override;
  649.   public
  650.     constructor Create(AOwner: TComponent); override;
  651.     destructor Destroy; override;
  652.     procedure CopyToClipboard;
  653.     procedure CutToClipboard;
  654.     procedure LoadPicture;
  655.     procedure PasteFromClipboard;
  656.     property Field: TField read GetField;
  657.     property Picture: TPicture read FPicture write SetPicture;
  658.   published
  659.     property Align;
  660.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  661.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  662.     property Center: Boolean read FCenter write SetCenter default True;
  663.     property Color;
  664.     property Ctl3D;
  665.     property DataField: string read GetDataField write SetDataField;
  666.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  667.     property DragCursor;
  668.     property DragMode;
  669.     property Enabled;
  670.     property Font;
  671.     property ParentColor default False;
  672.     property ParentCtl3D;
  673.     property ParentFont;
  674.     property ParentShowHint;
  675.     property PopupMenu;
  676.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  677.     property QuickDraw: Boolean read FQuickDraw write FQuickDraw default True;
  678.     property ShowHint;
  679.     property Stretch: Boolean read FStretch write SetStretch default False;
  680.     property TabOrder;
  681.     property TabStop default True;
  682.     property Visible;
  683.     property OnClick;
  684.     property OnDblClick;
  685.     property OnDragDrop;
  686.     property OnDragOver;
  687.     property OnEndDrag;
  688.     property OnEnter;
  689.     property OnExit;
  690.     property OnKeyDown;
  691.     property OnKeyPress;
  692.     property OnKeyUp;
  693.     property OnMouseDown;
  694.     property OnMouseMove;
  695.     property OnMouseUp;
  696.     property OnStartDrag;
  697.   end;
  698.  
  699. const
  700.   InitRepeatPause = 400;  { pause before repeat timer (ms) }
  701.   RepeatPause     = 100;  { pause before hint window displays (ms)}
  702.   SpaceSize       =  5;   { size of space between special buttons }
  703.  
  704. type
  705.   TNavButton = class;
  706.   TNavDataLink = class;
  707.  
  708.   TNavGlyph = (ngEnabled, ngDisabled);
  709.   TNavigateBtn = (nbFirst, nbPrior, nbNext, nbLast,
  710.                   nbInsert, nbDelete, nbEdit, nbPost, nbCancel, nbRefresh);
  711.   TButtonSet = set of TNavigateBtn;
  712.   TNavButtonStyle = set of (nsAllowTimer, nsFocusRect);
  713.  
  714.   ENavClick = procedure (Sender: TObject; Button: TNavigateBtn) of object;
  715.  
  716. { TDBNavigator }
  717.  
  718.   TDBNavigator = class (TCustomPanel)
  719.   private
  720.     FDataLink: TNavDataLink;
  721.     FVisibleButtons: TButtonSet;
  722.     FHints: TStrings;
  723.     ButtonWidth: Integer;
  724.     MinBtnSize: TPoint;
  725.     FOnNavClick: ENavClick;
  726.     FocusedButton: TNavigateBtn;
  727.     FConfirmDelete: Boolean;
  728.     FFlat: Boolean;
  729.     procedure ClickHandler(Sender: TObject);
  730.     function GetDataSource: TDataSource;
  731.     procedure SetDataSource(Value: TDataSource);
  732.     procedure InitButtons;
  733.     procedure InitHints;
  734.     procedure BtnMouseDown (Sender: TObject; Button: TMouseButton;
  735.       Shift: TShiftState; X, Y: Integer);
  736.     procedure SetVisible(Value: TButtonSet);
  737.     procedure AdjustSize (var W: Integer; var H: Integer);
  738.     procedure SetHints(Value: TStrings);
  739.     procedure SetFlat(Value: Boolean);
  740.     procedure WMSize(var Message: TWMSize);  message WM_SIZE;
  741.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  742.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  743.     procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  744.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  745.   protected
  746.     Buttons: array[TNavigateBtn] of TNavButton;
  747.     procedure DataChanged;
  748.     procedure EditingChanged;
  749.     procedure ActiveChanged;
  750.     procedure Loaded; override;
  751.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  752.     procedure Notification(AComponent: TComponent;
  753.       Operation: TOperation); override;
  754.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  755.   public
  756.     constructor Create(AOwner: TComponent); override;
  757.     destructor Destroy; override;
  758.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  759.     procedure BtnClick(Index: TNavigateBtn);
  760.   published
  761.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  762.     property VisibleButtons: TButtonSet read FVisibleButtons write SetVisible
  763.       default [nbFirst, nbPrior, nbNext, nbLast, nbInsert, nbDelete,
  764.         nbEdit, nbPost, nbCancel, nbRefresh];
  765.     property Align;
  766.     property DragCursor;
  767.     property DragMode;
  768.     property Enabled;
  769.     property Flat: Boolean read FFlat write SetFlat default False;
  770.     property Ctl3D;
  771.     property Hints: TStrings read FHints write SetHints;
  772.     property ParentCtl3D;
  773.     property ParentShowHint;
  774.     property PopupMenu;
  775.     property ConfirmDelete: Boolean read FConfirmDelete write FConfirmDelete default True;
  776.     property ShowHint;
  777.     property TabOrder;
  778.     property TabStop;
  779.     property Visible;
  780.     property OnClick: ENavClick read FOnNavClick write FOnNavClick;
  781.     property OnDblClick;
  782.     property OnDragDrop;
  783.     property OnDragOver;
  784.     property OnEndDrag;
  785.     property OnEnter;
  786.     property OnExit;
  787.     property OnResize;
  788.     property OnStartDrag;
  789.   end;
  790.  
  791. { TNavButton }
  792.  
  793.   TNavButton = class(TSpeedButton)
  794.   private
  795.     FIndex: TNavigateBtn;
  796.     FNavStyle: TNavButtonStyle;
  797.     FRepeatTimer: TTimer;
  798.     procedure TimerExpired(Sender: TObject);
  799.   protected
  800.     procedure Paint; override;
  801.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  802.       X, Y: Integer); override;
  803.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  804.       X, Y: Integer); override;
  805.   public
  806.     destructor Destroy; override;
  807.     property NavStyle: TNavButtonStyle read FNavStyle write FNavStyle;
  808.     property Index : TNavigateBtn read FIndex write FIndex;
  809.   end;
  810.  
  811. { TNavDataLink }
  812.  
  813.   TNavDataLink = class(TDataLink)
  814.   private
  815.     FNavigator: TDBNavigator;
  816.   protected
  817.     procedure EditingChanged; override;
  818.     procedure DataSetChanged; override;
  819.     procedure ActiveChanged; override;
  820.   public
  821.     constructor Create(ANav: TDBNavigator);
  822.     destructor Destroy; override;
  823.   end;
  824.  
  825. { TDBLookupControl }
  826.  
  827.   TDBLookupControl = class;
  828.  
  829.   TDataSourceLink = class(TDataLink)
  830.   private
  831.     FDBLookupControl: TDBLookupControl;
  832.   protected
  833.     procedure FocusControl(Field: TFieldRef); override;
  834.     procedure ActiveChanged; override;
  835.     procedure RecordChanged(Field: TField); override;
  836.   end;
  837.  
  838.   TListSourceLink = class(TDataLink)
  839.   private
  840.     FDBLookupControl: TDBLookupControl;
  841.   protected
  842.     procedure ActiveChanged; override;
  843.     procedure DataSetChanged; override;
  844.   end;
  845.  
  846.   TDBLookupControl = class(TCustomControl)
  847.   private
  848.     FLookupSource: TDataSource;
  849.     FDataLink: TDataSourceLink;
  850.     FListLink: TListSourceLink;
  851.     FDataFieldName: string;
  852.     FKeyFieldName: string;
  853.     FListFieldName: string;
  854.     FListFieldIndex: Integer;
  855.     FDataField: TField;
  856.     FMasterField: TField;
  857.     FKeyField: TField;
  858.     FListField: TField;
  859.     FListFields: TList;
  860.     FKeyValue: Variant;
  861.     FSearchText: string;
  862.     FLookupMode: Boolean;
  863.     FListActive: Boolean;
  864.     FFocused: Boolean;
  865.     function CanModify: Boolean;
  866.     procedure CheckNotCircular;
  867.     procedure CheckNotLookup;
  868.     procedure DataLinkActiveChanged;
  869.     procedure DataLinkRecordChanged(Field: TField);
  870.     function GetBorderSize: Integer;
  871.     function GetDataSource: TDataSource;
  872.     function GetKeyFieldName: string;
  873.     function GetListSource: TDataSource;
  874.     function GetReadOnly: Boolean;
  875.     function GetTextHeight: Integer;
  876.     procedure KeyValueChanged; virtual;
  877.     procedure ListLinkActiveChanged; virtual;
  878.     procedure ListLinkDataChanged; virtual;
  879.     function LocateKey: Boolean;
  880.     procedure ProcessSearchKey(Key: Char);
  881.     procedure SelectKeyValue(const Value: Variant);
  882.     procedure SetDataFieldName(const Value: string);
  883.     procedure SetDataSource(Value: TDataSource);
  884.     procedure SetKeyFieldName(const Value: string);
  885.     procedure SetKeyValue(const Value: Variant);
  886.     procedure SetListFieldName(const Value: string);
  887.     procedure SetListSource(Value: TDataSource);
  888.     procedure SetLookupMode(Value: Boolean);
  889.     procedure SetReadOnly(Value: Boolean);
  890.     procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
  891.     procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
  892.     procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
  893.   protected
  894.     procedure Notification(AComponent: TComponent;
  895.       Operation: TOperation); override;
  896.     property DataField: string read FDataFieldName write SetDataFieldName;
  897.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  898.     property KeyField: string read GetKeyFieldName write SetKeyFieldName;
  899.     property KeyValue: Variant read FKeyValue write SetKeyValue;
  900.     property ListField: string read FListFieldName write SetListFieldName;
  901.     property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0;
  902.     property ListSource: TDataSource read GetListSource write SetListSource;
  903.     property ParentColor default False;
  904.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  905.     property TabStop default True;
  906.   public
  907.     constructor Create(AOwner: TComponent); override;
  908.     destructor Destroy; override;
  909.     property Field: TField read FDataField;
  910.   end;
  911.  
  912. { TDBLookupListBox }
  913.  
  914.   TDBLookupListBox = class(TDBLookupControl)
  915.   private
  916.     FRecordIndex: Integer;
  917.     FRecordCount: Integer;
  918.     FRowCount: Integer;
  919.     FBorderStyle: TBorderStyle;
  920.     FPopup: Boolean;
  921.     FKeySelected: Boolean;
  922.     FTracking: Boolean;
  923.     FTimerActive: Boolean;
  924.     FLockPosition: Boolean;
  925.     FMousePos: Integer;
  926.     FSelectedItem: string;
  927.     function GetKeyIndex: Integer;
  928.     procedure KeyValueChanged; override;
  929.     procedure ListLinkActiveChanged; override;
  930.     procedure ListLinkDataChanged; override;
  931.     procedure SelectCurrent;
  932.     procedure SelectItemAt(X, Y: Integer);
  933.     procedure SetBorderStyle(Value: TBorderStyle);
  934.     procedure SetRowCount(Value: Integer);
  935.     procedure StopTimer;
  936.     procedure StopTracking;
  937.     procedure TimerScroll;
  938.     procedure UpdateScrollBar;
  939.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  940.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  941.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  942.     procedure WMTimer(var Message: TMessage); message WM_TIMER;
  943.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  944.   protected
  945.     procedure CreateParams(var Params: TCreateParams); override;
  946.     procedure CreateWnd; override;
  947.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  948.     procedure KeyPress(var Key: Char); override;
  949.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  950.       X, Y: Integer); override;
  951.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  952.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  953.       X, Y: Integer); override;
  954.     procedure Paint; override;
  955.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  956.   public
  957.     constructor Create(AOwner: TComponent); override;
  958.     property KeyValue;
  959.     property SelectedItem: string read FSelectedItem;
  960.   published
  961.     property Align;
  962.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  963.     property Color;
  964.     property Ctl3D;
  965.     property DataField;
  966.     property DataSource;
  967.     property DragCursor;
  968.     property DragMode;
  969.     property Enabled;
  970.     property Font;
  971.     property ImeMode;
  972.     property ImeName;
  973.     property KeyField;
  974.     property ListField;
  975.     property ListFieldIndex;
  976.     property ListSource;
  977.     property ParentColor;
  978.     property ParentCtl3D;
  979.     property ParentFont;
  980.     property ParentShowHint;
  981.     property PopupMenu;
  982.     property ReadOnly;
  983.     property RowCount: Integer read FRowCount write SetRowCount stored False;
  984.     property ShowHint;
  985.     property TabOrder;
  986.     property TabStop;
  987.     property Visible;
  988.     property OnClick;
  989.     property OnDblClick;
  990.     property OnDragDrop;
  991.     property OnDragOver;
  992.     property OnEndDrag;
  993.     property OnEnter;
  994.     property OnExit;
  995.     property OnKeyDown;
  996.     property OnKeyPress;
  997.     property OnKeyUp;
  998.     property OnMouseDown;
  999.     property OnMouseMove;
  1000.     property OnMouseUp;
  1001.     property OnStartDrag;
  1002.   end;
  1003.  
  1004. { TDBLookupComboBox }
  1005.  
  1006.   TPopupDataList = class(TDBLookupListBox)
  1007.   private
  1008.     procedure WMMouseActivate(var Message: TMessage); message WM_MOUSEACTIVATE;
  1009.   protected
  1010.     procedure CreateParams(var Params: TCreateParams); override;
  1011.   public
  1012.     constructor Create(AOwner: TComponent); override;
  1013.   end;
  1014.  
  1015.   TDropDownAlign = (daLeft, daRight, daCenter);
  1016.  
  1017.   TDBLookupComboBox = class(TDBLookupControl)
  1018.   private
  1019.     FDataList: TPopupDataList;
  1020.     FButtonWidth: Integer;
  1021.     FText: string;
  1022.     FDropDownRows: Integer;
  1023.     FDropDownWidth: Integer;
  1024.     FDropDownAlign: TDropDownAlign;
  1025.     FListVisible: Boolean;
  1026.     FPressed: Boolean;
  1027.     FTracking: Boolean;
  1028.     FAlignment: TAlignment;
  1029.     FLookupMode: Boolean;
  1030.     FOnDropDown: TNotifyEvent;
  1031.     FOnCloseUp: TNotifyEvent;
  1032.     procedure KeyValueChanged; override;
  1033.     procedure ListLinkActiveChanged; override;
  1034.     procedure ListMouseUp(Sender: TObject; Button: TMouseButton;
  1035.       Shift: TShiftState; X, Y: Integer);
  1036.     procedure StopTracking;
  1037.     procedure TrackButton(X, Y: Integer);
  1038.     procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
  1039.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  1040.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  1041.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  1042.     procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
  1043.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  1044.   protected
  1045.     procedure CreateParams(var Params: TCreateParams); override;
  1046.     procedure Paint; override;
  1047.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  1048.     procedure KeyPress(var Key: Char); override;
  1049.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  1050.       X, Y: Integer); override;
  1051.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  1052.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  1053.       X, Y: Integer); override;
  1054.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  1055.   public
  1056.     constructor Create(AOwner: TComponent); override;
  1057.     procedure CloseUp(Accept: Boolean);
  1058.     procedure DropDown;
  1059.     property KeyValue;
  1060.     property ListVisible: Boolean read FListVisible;
  1061.     property Text: string read FText;
  1062.   published
  1063.     property Color;
  1064.     property Ctl3D;
  1065.     property DataField;
  1066.     property DataSource;
  1067.     property DragCursor;
  1068.     property DragMode;
  1069.     property DropDownAlign: TDropDownAlign read FDropDownAlign write FDropDownAlign default daLeft;
  1070.     property DropDownRows: Integer read FDropDownRows write FDropDownRows default 7;
  1071.     property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
  1072.     property Enabled;
  1073.     property Font;
  1074.     property ImeMode;
  1075.     property ImeName;
  1076.     property KeyField;
  1077.     property ListField;
  1078.     property ListFieldIndex;
  1079.     property ListSource;
  1080.     property ParentColor;
  1081.     property ParentCtl3D;
  1082.     property ParentFont;
  1083.     property ParentShowHint;
  1084.     property PopupMenu;
  1085.     property ReadOnly;
  1086.     property ShowHint;
  1087.     property TabOrder;
  1088.     property TabStop;
  1089.     property Visible;
  1090.     property OnClick;
  1091.     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  1092.     property OnDragDrop;
  1093.     property OnDragOver;
  1094.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  1095.     property OnEndDrag;
  1096.     property OnEnter;
  1097.     property OnExit;
  1098.     property OnKeyDown;
  1099.     property OnKeyPress;
  1100.     property OnKeyUp;
  1101.     property OnMouseDown;
  1102.     property OnMouseMove;
  1103.     property OnMouseUp;
  1104.     property OnStartDrag;
  1105.   end;
  1106.  
  1107. { TDBRichEdit }
  1108.  
  1109.   TDBRichEdit = class(TCustomRichEdit)
  1110.   private
  1111.     FDataLink: TFieldDataLink;
  1112.     FAutoDisplay: Boolean;
  1113.     FFocused: Boolean;
  1114.     FMemoLoaded: Boolean;
  1115.     FDataSave: string;
  1116.     procedure BeginEditing;
  1117.     procedure DataChange(Sender: TObject);
  1118.     procedure EditingChange(Sender: TObject);
  1119.     function GetDataField: string;
  1120.     function GetDataSource: TDataSource;
  1121.     function GetField: TField;
  1122.     function GetReadOnly: Boolean;
  1123.     procedure SetDataField(const Value: string);
  1124.     procedure SetDataSource(Value: TDataSource);
  1125.     procedure SetReadOnly(Value: Boolean);
  1126.     procedure SetAutoDisplay(Value: Boolean);
  1127.     procedure SetFocused(Value: Boolean);
  1128.     procedure UpdateData(Sender: TObject);
  1129.     procedure WMCut(var Message: TMessage); message WM_CUT;
  1130.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  1131.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  1132.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  1133.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  1134.     procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  1135.   protected
  1136.     procedure Change; override;
  1137.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  1138.     procedure KeyPress(var Key: Char); override;
  1139.     procedure Notification(AComponent: TComponent;
  1140.       Operation: TOperation); override;
  1141.   public
  1142.     constructor Create(AOwner: TComponent); override;
  1143.     destructor Destroy; override;
  1144.     procedure LoadMemo;
  1145.     property Field: TField read GetField;
  1146.   published
  1147.     property Align;
  1148.     property Alignment;
  1149.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  1150.     property BorderStyle;
  1151.     property Color;
  1152.     property Ctl3D;
  1153.     property DataField: string read GetDataField write SetDataField;
  1154.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  1155.     property DragCursor;
  1156.     property DragMode;
  1157.     property Enabled;
  1158.     property Font;
  1159.     property HideSelection;
  1160.     property HideScrollBars;
  1161.     property ImeMode;
  1162.     property ImeName;
  1163.     property MaxLength;
  1164.     property ParentColor;
  1165.     property ParentCtl3D;
  1166.     property ParentFont;
  1167.     property ParentShowHint;
  1168.     property PlainText;
  1169.     property PopupMenu;
  1170.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  1171.     property ScrollBars;
  1172.     property ShowHint;
  1173.     property TabOrder;
  1174.     property TabStop;
  1175.     property Visible;
  1176.     property WantReturns;
  1177.     property WantTabs;
  1178.     property WordWrap;
  1179.     property OnChange;
  1180.     property OnClick;
  1181.     property OnDblClick;
  1182.     property OnDragDrop;
  1183.     property OnDragOver;
  1184.     property OnEndDrag;
  1185.     property OnEnter;
  1186.     property OnExit;
  1187.     property OnKeyDown;
  1188.     property OnKeyPress;
  1189.     property OnKeyUp;
  1190.     property OnMouseDown;
  1191.     property OnMouseMove;
  1192.     property OnMouseUp;
  1193.     property OnResizeRequest;
  1194.     property OnSelectionChange;
  1195.     property OnProtectChange;
  1196.     property OnSaveClipboard;
  1197.     property OnStartDrag;
  1198.   end;
  1199.  
  1200. implementation
  1201.  
  1202. uses Clipbrd, DBConsts, Dialogs;
  1203.  
  1204. {$R DBCTRLS}
  1205.  
  1206. { TFieldDataLink }
  1207.  
  1208. constructor TFieldDataLink.Create(AControl: TControl);
  1209. begin
  1210.   inherited Create;
  1211.   FControl := AControl;
  1212. end;
  1213.  
  1214. procedure TFieldDataLink.SetEditing(Value: Boolean);
  1215. begin
  1216.   if FEditing <> Value then
  1217.   begin
  1218.     FEditing := Value;
  1219.     FModified := False;
  1220.     if Assigned(FOnEditingChange) then FOnEditingChange(Self);
  1221.   end;
  1222. end;
  1223.  
  1224. procedure TFieldDataLink.SetFieldName(const Value: string);
  1225. begin
  1226.   if FFieldName <> Value then
  1227.   begin
  1228.     FFieldName :=  Value;
  1229.     UpdateField;
  1230.   end;
  1231. end;
  1232.  
  1233. procedure TFieldDataLink.SetField(Value: TField);
  1234. begin
  1235.   if FField <> Value then
  1236.   begin
  1237.     FField := Value;
  1238.     EditingChanged;
  1239.     RecordChanged(nil);
  1240.   end;
  1241. end;
  1242.  
  1243. procedure TFieldDataLink.UpdateField;
  1244. begin
  1245.   SetField(nil);
  1246.   if Active and (FFieldName <> '') then
  1247.     SetField(GetFieldProperty(DataSource.DataSet, FControl, FFieldName));
  1248. end;
  1249.  
  1250. function TFieldDataLink.Edit: Boolean;
  1251. begin
  1252.   if CanModify then inherited Edit;
  1253.   Result := FEditing;
  1254. end;
  1255.  
  1256. function TFieldDataLink.GetCanModify: Boolean;
  1257. begin
  1258.   Result := not ReadOnly and (Field <> nil) and Field.CanModify;
  1259. end;
  1260.  
  1261. procedure TFieldDataLink.Modified;
  1262. begin
  1263.   FModified := True;
  1264. end;
  1265.  
  1266. procedure TFieldDataLink.Reset;
  1267. begin
  1268.   RecordChanged(nil);
  1269. end;
  1270.  
  1271. procedure TFieldDataLink.ActiveChanged;
  1272. begin
  1273.   UpdateField;
  1274.   if Assigned(FOnActiveChange) then FOnActiveChange(Self);
  1275. end;
  1276.  
  1277. procedure TFieldDataLink.EditingChanged;
  1278. begin
  1279.   SetEditing(inherited Editing and CanModify);
  1280. end;
  1281.  
  1282. procedure TFieldDataLink.FocusControl(Field: TFieldRef);
  1283. begin
  1284.   if (Field^ <> nil) and (Field^ = FField) and (FControl is TWinControl) then
  1285.     if TWinControl(FControl).CanFocus then
  1286.     begin
  1287.       Field^ := nil;
  1288.       TWinControl(FControl).SetFocus;
  1289.     end;
  1290. end;
  1291.  
  1292. procedure TFieldDataLink.RecordChanged(Field: TField);
  1293. begin
  1294.   if (Field = nil) or (Field = FField) then
  1295.   begin
  1296.     if Assigned(FOnDataChange) then FOnDataChange(Self);
  1297.     FModified := False;
  1298.   end;
  1299. end;
  1300.  
  1301. procedure TFieldDataLink.LayoutChanged;
  1302. begin
  1303.   UpdateField;
  1304. end;
  1305.  
  1306. procedure TFieldDataLink.UpdateData;
  1307. begin
  1308.   if FModified then
  1309.   begin
  1310.     if (Field <> nil) and Assigned(FOnUpdateData) then FOnUpdateData(Self);
  1311.     FModified := False;
  1312.   end;
  1313. end;
  1314.  
  1315. { TPaintControl }
  1316.  
  1317. type
  1318.   TWinControlAccess = class(TWinControl);
  1319.  
  1320. constructor TPaintControl.Create(AOwner: TWinControl; const ClassName: string);
  1321. begin
  1322.   FOwner := AOwner;
  1323.   FClassName := ClassName;
  1324. end;
  1325.  
  1326. destructor TPaintControl.Destroy;
  1327. begin
  1328.   DestroyHandle;
  1329. end;
  1330.  
  1331. procedure TPaintControl.DestroyHandle;
  1332. begin
  1333.   if FHandle <> 0 then DestroyWindow(FHandle);
  1334.   FreeObjectInstance(FObjectInstance);
  1335.   FHandle := 0;
  1336.   FObjectInstance := nil;
  1337. end;
  1338.  
  1339. function TPaintControl.GetHandle: HWnd;
  1340. var
  1341.   Params: TCreateParams;
  1342. begin
  1343.   if FHandle = 0 then
  1344.   begin
  1345.     FObjectInstance := MakeObjectInstance(WndProc);
  1346.     TWinControlAccess(FOwner).CreateParams(Params);
  1347.     Params.Style := Params.Style and not (WS_HSCROLL or WS_VSCROLL);
  1348.     with Params do
  1349.       FHandle := CreateWindowEx(ExStyle, PChar(FClassName),
  1350.         PChar(TWinControlAccess(FOwner).Text), Style or WS_VISIBLE,
  1351.         X, Y, Width, Height, Application.Handle, 0, HInstance, nil);
  1352.     if FCtl3DButton and TWinControlAccess(FOwner).Ctl3D
  1353.       and not NewStyleControls then
  1354.       Subclass3DWnd(FHandle);
  1355.     FDefWindowProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
  1356.     SetWindowLong(FHandle, GWL_WNDPROC, Integer(FObjectInstance));
  1357.     SendMessage(FHandle, WM_SETFONT,
  1358.       TWinControlAccess(FOwner).Font.Handle, 1);
  1359.   end;
  1360.   Result := FHandle;
  1361. end;
  1362.  
  1363. procedure TPaintControl.SetCtl3DButton(Value: Boolean);
  1364. begin
  1365.   if FHandle <> 0 then DestroyHandle;
  1366.   FCtl3DButton := Value;
  1367. end;
  1368.  
  1369. procedure TPaintControl.WndProc(var Message: TMessage);
  1370. begin
  1371.   with Message do
  1372.     if (Msg >= CN_CTLCOLORMSGBOX) and (Msg <= CN_CTLCOLORSTATIC) then
  1373.       Result := FOwner.Perform(Msg, WParam, LParam) else
  1374.       Result := CallWindowProc(FDefWindowProc, FHandle, Msg, WParam, LParam);
  1375. end;
  1376.  
  1377. { TDBEdit }
  1378.  
  1379. constructor TDBEdit.Create(AOwner: TComponent);
  1380. begin
  1381.   inherited Create(AOwner);
  1382.   inherited ReadOnly := True;
  1383.   ControlStyle := ControlStyle + [csReplicatable];
  1384.   FDataLink := TFieldDataLink.Create(Self);
  1385.   FDataLink.OnDataChange := DataChange;
  1386.   FDataLink.OnEditingChange := EditingChange;
  1387.   FDataLink.OnUpdateData := UpdateData;
  1388. end;
  1389.  
  1390. destructor TDBEdit.Destroy;
  1391. begin
  1392.   FDataLink.Free;
  1393.   FDataLink := nil;
  1394.   FCanvas.Free;
  1395.   inherited Destroy;
  1396. end;
  1397.  
  1398. procedure TDBEdit.Notification(AComponent: TComponent;
  1399.   Operation: TOperation);
  1400. begin
  1401.   inherited Notification(AComponent, Operation);
  1402.   if (Operation = opRemove) and (FDataLink <> nil) and
  1403.     (AComponent = DataSource) then DataSource := nil;
  1404. end;
  1405.  
  1406. procedure TDBEdit.KeyDown(var Key: Word; Shift: TShiftState);
  1407. begin
  1408.   inherited KeyDown(Key, Shift);
  1409.   if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then
  1410.     FDataLink.Edit;
  1411. end;
  1412.  
  1413. procedure TDBEdit.KeyPress(var Key: Char);
  1414. begin
  1415.   inherited KeyPress(Key);
  1416.   if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
  1417.     not FDataLink.Field.IsValidChar(Key) then
  1418.   begin
  1419.     MessageBeep(0);
  1420.     Key := #0;
  1421.   end;
  1422.   case Key of
  1423.     ^H, ^V, ^X, #32..#255:
  1424.       FDataLink.Edit;
  1425.     #27:
  1426.       begin
  1427.         FDataLink.Reset;
  1428.         SelectAll;
  1429.         Key := #0;
  1430.       end;
  1431.   end;
  1432. end;
  1433.  
  1434. function TDBEdit.EditCanModify: Boolean;
  1435. begin
  1436.   Result := FDataLink.Edit;
  1437. end;
  1438.  
  1439. procedure TDBEdit.Reset;
  1440. begin
  1441.   FDataLink.Reset;
  1442.   SelectAll;
  1443. end;
  1444.  
  1445. procedure TDBEdit.SetFocused(Value: Boolean);
  1446. begin
  1447.   if FFocused <> Value then
  1448.   begin
  1449.     FFocused := Value;
  1450.     if (FAlignment <> taLeftJustify) and not IsMasked then Invalidate;
  1451.     FDataLink.Reset;
  1452.   end;
  1453. end;
  1454.  
  1455. procedure TDBEdit.Change;
  1456. begin
  1457.   FDataLink.Modified;
  1458.   inherited Change;
  1459. end;
  1460.  
  1461. function TDBEdit.GetDataSource: TDataSource;
  1462. begin
  1463.   Result := FDataLink.DataSource;
  1464. end;
  1465.  
  1466. procedure TDBEdit.SetDataSource(Value: TDataSource);
  1467. begin
  1468.   FDataLink.DataSource := Value;
  1469.   if Value <> nil then Value.FreeNotification(Self);
  1470. end;
  1471.  
  1472. function TDBEdit.GetDataField: string;
  1473. begin
  1474.   Result := FDataLink.FieldName;
  1475. end;
  1476.  
  1477. procedure TDBEdit.SetDataField(const Value: string);
  1478. begin
  1479.   FDataLink.FieldName := Value;
  1480. end;
  1481.  
  1482. function TDBEdit.GetReadOnly: Boolean;
  1483. begin
  1484.   Result := FDataLink.ReadOnly;
  1485. end;
  1486.  
  1487. procedure TDBEdit.SetReadOnly(Value: Boolean);
  1488. begin
  1489.   FDataLink.ReadOnly := Value;
  1490. end;
  1491.  
  1492. function TDBEdit.GetField: TField;
  1493. begin
  1494.   Result := FDataLink.Field;
  1495. end;
  1496.  
  1497. procedure TDBEdit.DataChange(Sender: TObject);
  1498. begin
  1499.   if FDataLink.Field <> nil then
  1500.   begin
  1501.     if FAlignment <> FDataLink.Field.Alignment then
  1502.     begin
  1503.       EditText := '';  {forces update}
  1504.       FAlignment := FDataLink.Field.Alignment;
  1505.     end;
  1506.     EditMask := FDataLink.Field.EditMask;
  1507.     if FFocused and FDataLink.CanModify then
  1508.       Text := FDataLink.Field.Text
  1509.     else
  1510.       EditText := FDataLink.Field.DisplayText;
  1511.   end else
  1512.   begin
  1513.     FAlignment := taLeftJustify;
  1514.     EditMask := '';
  1515.     if csDesigning in ComponentState then
  1516.       EditText := Name else
  1517.       EditText := '';
  1518.   end;
  1519. end;
  1520.  
  1521. procedure TDBEdit.EditingChange(Sender: TObject);
  1522. begin
  1523.   inherited ReadOnly := not FDataLink.Editing;
  1524. end;
  1525.  
  1526. procedure TDBEdit.UpdateData(Sender: TObject);
  1527. begin
  1528.   ValidateEdit;
  1529.   FDataLink.Field.Text := Text;
  1530. end;
  1531.  
  1532. procedure TDBEdit.WMPaste(var Message: TMessage);
  1533. begin
  1534.   FDataLink.Edit;
  1535.   inherited;
  1536. end;
  1537.  
  1538. procedure TDBEdit.WMCut(var Message: TMessage);
  1539. begin
  1540.   FDataLink.Edit;
  1541.   inherited;
  1542. end;
  1543.  
  1544. procedure TDBEdit.CMEnter(var Message: TCMEnter);
  1545. begin
  1546.   SetFocused(True);
  1547.   inherited;
  1548. end;
  1549.  
  1550. procedure TDBEdit.CMExit(var Message: TCMExit);
  1551. begin
  1552.   try
  1553.     FDataLink.UpdateRecord;
  1554.   except
  1555.     SelectAll;
  1556.     SetFocus;
  1557.     raise;
  1558.   end;
  1559.   SetFocused(False);
  1560.   CheckCursor;
  1561.   DoExit;
  1562. end;
  1563.  
  1564. procedure TDBEdit.WMPaint(var Message: TWMPaint);
  1565. var
  1566.   Left: Integer;
  1567.   Margins: TPoint;
  1568.   R: TRect;
  1569.   DC: HDC;
  1570.   PS: TPaintStruct;
  1571.   S: string;
  1572. begin
  1573.   if ((FAlignment = taLeftJustify) or FFocused) and
  1574.     not (csPaintCopy in ControlState) then
  1575.   begin
  1576.     inherited;
  1577.     Exit;
  1578.   end;
  1579. { Since edit controls do not handle justification unless multi-line (and
  1580.   then only poorly) we will draw right and center justify manually unless
  1581.   the edit has the focus. }
  1582.   if FCanvas = nil then
  1583.   begin
  1584.     FCanvas := TControlCanvas.Create;
  1585.     FCanvas.Control := Self;
  1586.   end;
  1587.   DC := Message.DC;
  1588.   if DC = 0 then DC := BeginPaint(Handle, PS);
  1589.   FCanvas.Handle := DC;
  1590.   try
  1591.     FCanvas.Font := Font;
  1592.     with FCanvas do
  1593.     begin
  1594.       R := ClientRect;
  1595.       if not (NewStyleControls and Ctl3D) and (BorderStyle = bsSingle) then
  1596.       begin
  1597.         Brush.Color := clWindowFrame;
  1598.         FrameRect(R);
  1599.         InflateRect(R, -1, -1);
  1600.       end;
  1601.       Brush.Color := Color;
  1602.       if (csPaintCopy in ControlState) and (FDataLink.Field <> nil) then
  1603.       begin
  1604.         S := FDataLink.Field.DisplayText;
  1605.         case CharCase of
  1606.           ecUpperCase: S := AnsiUpperCase(S);
  1607.           ecLowerCase: S := AnsiLowerCase(S);
  1608.         end;
  1609.       end else
  1610.         S := EditText;
  1611.       if PasswordChar <> #0 then FillChar(S[1], Length(S), PasswordChar);
  1612.       Margins := GetTextMargins;
  1613.       case FAlignment of
  1614.         taLeftJustify: Left := Margins.X;
  1615.         taRightJustify: Left := ClientWidth - TextWidth(S) - Margins.X - 1;
  1616.       else
  1617.         Left := (ClientWidth - TextWidth(S)) div 2;
  1618.       end;
  1619.       TextRect(R, Left, Margins.Y, S);
  1620.     end;
  1621.   finally
  1622.     FCanvas.Handle := 0;
  1623.     if Message.DC = 0 then EndPaint(Handle, PS);
  1624.   end;
  1625. end;
  1626.  
  1627. procedure TDBEdit.CMGetDataLink(var Message: TMessage);
  1628. begin
  1629.   Message.Result := Integer(FDataLink);
  1630. end;
  1631.  
  1632. function TDBEdit.GetTextMargins: TPoint;
  1633. var
  1634.   DC: HDC;
  1635.   SaveFont: HFont;
  1636.   I: Integer;
  1637.   SysMetrics, Metrics: TTextMetric;
  1638. begin
  1639.   if NewStyleControls then
  1640.   begin
  1641.     if BorderStyle = bsNone then I := 0 else
  1642.       if Ctl3D then I := 1 else I := 2;
  1643.     Result.X := SendMessage(Handle, EM_GETMARGINS, 0, 0) and $0000FFFF + I;
  1644.     Result.Y := I;
  1645.   end else
  1646.   begin
  1647.     if BorderStyle = bsNone then I := 0 else
  1648.     begin
  1649.       DC := GetDC(0);
  1650.       GetTextMetrics(DC, SysMetrics);
  1651.       SaveFont := SelectObject(DC, Font.Handle);
  1652.       GetTextMetrics(DC, Metrics);
  1653.       SelectObject(DC, SaveFont);
  1654.       ReleaseDC(0, DC);
  1655.       I := SysMetrics.tmHeight;
  1656.       if I > Metrics.tmHeight then I := Metrics.tmHeight;
  1657.       I := I div 4;
  1658.     end;
  1659.     Result.X := I;
  1660.     Result.Y := I;
  1661.   end;
  1662. end;
  1663.  
  1664. { TDBText }
  1665.  
  1666. constructor TDBText.Create(AOwner: TComponent);
  1667. begin
  1668.   inherited Create(AOwner);
  1669.   ControlStyle := ControlStyle + [csReplicatable];
  1670.   AutoSize := False;
  1671.   ShowAccelChar := False;
  1672.   FDataLink := TFieldDataLink.Create(Self);
  1673.   FDataLink.OnDataChange := DataChange;
  1674. end;
  1675.  
  1676. destructor TDBText.Destroy;
  1677. begin
  1678.   FDataLink.Free;
  1679.   FDataLink := nil;
  1680.   inherited Destroy;
  1681. end;
  1682.  
  1683. procedure TDBText.Notification(AComponent: TComponent;
  1684.   Operation: TOperation);
  1685. begin
  1686.   inherited Notification(AComponent, Operation);
  1687.   if (Operation = opRemove) and (FDataLink <> nil) and
  1688.     (AComponent = DataSource) then DataSource := nil;
  1689. end;
  1690.  
  1691. procedure TDBText.SetAutoSize(Value: Boolean);
  1692. begin
  1693.   if AutoSize <> Value then
  1694.   begin
  1695.     if Value and FDataLink.DataSourceFixed then DatabaseError(SDataSourceFixed);
  1696.     inherited SetAutoSize(Value);
  1697.   end;
  1698. end;
  1699.  
  1700. function TDBText.GetDataSource: TDataSource;
  1701. begin
  1702.   Result := FDataLink.DataSource;
  1703. end;
  1704.  
  1705. procedure TDBText.SetDataSource(Value: TDataSource);
  1706. begin
  1707.   FDataLink.DataSource := Value;
  1708.   if Value <> nil then Value.FreeNotification(Self);
  1709. end;
  1710.  
  1711. function TDBText.GetDataField: string;
  1712. begin
  1713.   Result := FDataLink.FieldName;
  1714. end;
  1715.  
  1716. procedure TDBText.SetDataField(const Value: string);
  1717. begin
  1718.   FDataLink.FieldName := Value;
  1719. end;
  1720.  
  1721. function TDBText.GetField: TField;
  1722. begin
  1723.   Result := FDataLink.Field;
  1724. end;
  1725.  
  1726. function TDBText.GetFieldText: string;
  1727. begin
  1728.   if FDataLink.Field <> nil then
  1729.     Result := FDataLink.Field.DisplayText
  1730.   else
  1731.     if csDesigning in ComponentState then Result := Name else Result := '';
  1732. end;
  1733.  
  1734. procedure TDBText.DataChange(Sender: TObject);
  1735. begin
  1736.   Caption := GetFieldText;
  1737. end;
  1738.  
  1739. function TDBText.GetLabelText: string;
  1740. begin
  1741.   if csPaintCopy in ControlState then
  1742.     Result := GetFieldText else
  1743.     Result := Caption;
  1744. end;
  1745.  
  1746. procedure TDBText.CMGetDataLink(var Message: TMessage);
  1747. begin
  1748.   Message.Result := Integer(FDataLink);
  1749. end;
  1750.  
  1751. { TDBCheckBox }
  1752.  
  1753. constructor TDBCheckBox.Create(AOwner: TComponent);
  1754. begin
  1755.   inherited Create(AOwner);
  1756.   ControlStyle := ControlStyle + [csReplicatable];
  1757.   State := cbUnchecked;
  1758.   FValueCheck := STextTrue;
  1759.   FValueUncheck := STextFalse;
  1760.   FDataLink := TFieldDataLink.Create(Self);
  1761.   FDataLink.OnDataChange := DataChange;
  1762.   FDataLink.OnUpdateData := UpdateData;
  1763.   FPaintControl := TPaintControl.Create(Self, 'BUTTON');
  1764.   FPaintControl.Ctl3DButton := True;
  1765. end;
  1766.  
  1767. destructor TDBCheckBox.Destroy;
  1768. begin
  1769.   FPaintControl.Free;
  1770.   FDataLink.Free;
  1771.   FDataLink := nil;
  1772.   inherited Destroy;
  1773. end;
  1774.  
  1775. procedure TDBCheckBox.Notification(AComponent: TComponent;
  1776.   Operation: TOperation);
  1777. begin
  1778.   inherited Notification(AComponent, Operation);
  1779.   if (Operation = opRemove) and (FDataLink <> nil) and
  1780.     (AComponent = DataSource) then DataSource := nil;
  1781. end;
  1782.  
  1783. function TDBCheckBox.GetFieldState: TCheckBoxState;
  1784. var
  1785.   Text: string;
  1786. begin
  1787.   if FDatalink.Field <> nil then
  1788.     if FDataLink.Field.IsNull then
  1789.       Result := cbGrayed
  1790.     else if FDataLink.Field.DataType = ftBoolean then
  1791.       if FDataLink.Field.AsBoolean then
  1792.         Result := cbChecked
  1793.       else
  1794.         Result := cbUnchecked
  1795.     else
  1796.     begin
  1797.       Result := cbGrayed;
  1798.       Text := FDataLink.Field.Text;
  1799.       if ValueMatch(FValueCheck, Text) then Result := cbChecked else
  1800.         if ValueMatch(FValueUncheck, Text) then Result := cbUnchecked;
  1801.     end
  1802.   else
  1803.     Result := cbUnchecked;
  1804. end;
  1805.  
  1806. procedure TDBCheckBox.DataChange(Sender: TObject);
  1807. begin
  1808.   State := GetFieldState;
  1809. end;
  1810.  
  1811. procedure TDBCheckBox.UpdateData(Sender: TObject);
  1812. var
  1813.   Pos: Integer;
  1814.   S: string;
  1815. begin
  1816.   if State = cbGrayed then
  1817.     FDataLink.Field.Clear
  1818.   else
  1819.     if FDataLink.Field.DataType = ftBoolean then
  1820.       FDataLink.Field.AsBoolean := Checked
  1821.     else
  1822.     begin
  1823.       if Checked then S := FValueCheck else S := FValueUncheck;
  1824.       Pos := 1;
  1825.       FDataLink.Field.Text := ExtractFieldName(S, Pos);
  1826.     end;
  1827. end;
  1828.  
  1829. function TDBCheckBox.ValueMatch(const ValueList, Value: string): Boolean;
  1830. var
  1831.   Pos: Integer;
  1832. begin
  1833.   Result := False;
  1834.   Pos := 1;
  1835.   while Pos <= Length(ValueList) do
  1836.     if AnsiCompareText(ExtractFieldName(ValueList, Pos), Value) = 0 then
  1837.     begin
  1838.       Result := True;
  1839.       Break;
  1840.     end;
  1841. end;
  1842.  
  1843. procedure TDBCheckBox.Toggle;
  1844. begin
  1845.   if FDataLink.Edit then
  1846.   begin
  1847.     inherited Toggle;
  1848.     FDataLink.Modified;
  1849.   end;
  1850. end;
  1851.  
  1852. function TDBCheckBox.GetDataSource: TDataSource;
  1853. begin
  1854.   Result := FDataLink.DataSource;
  1855. end;
  1856.  
  1857. procedure TDBCheckBox.SetDataSource(Value: TDataSource);
  1858. begin
  1859.   FDataLink.DataSource := Value;
  1860.   if Value <> nil then Value.FreeNotification(Self);
  1861. end;
  1862.  
  1863. function TDBCheckBox.GetDataField: string;
  1864. begin
  1865.   Result := FDataLink.FieldName;
  1866. end;
  1867.  
  1868. procedure TDBCheckBox.SetDataField(const Value: string);
  1869. begin
  1870.   FDataLink.FieldName := Value;
  1871. end;
  1872.  
  1873. function TDBCheckBox.GetReadOnly: Boolean;
  1874. begin
  1875.   Result := FDataLink.ReadOnly;
  1876. end;
  1877.  
  1878. procedure TDBCheckBox.SetReadOnly(Value: Boolean);
  1879. begin
  1880.   FDataLink.ReadOnly := Value;
  1881. end;
  1882.  
  1883. function TDBCheckBox.GetField: TField;
  1884. begin
  1885.   Result := FDataLink.Field;
  1886. end;
  1887.  
  1888. procedure TDBCheckBox.KeyPress(var Key: Char);
  1889. begin
  1890.   inherited KeyPress(Key);
  1891.   case Key of
  1892.     #8, ' ':
  1893.       FDataLink.Edit;
  1894.     #27:
  1895.       FDataLink.Reset;
  1896.   end;
  1897. end;
  1898.  
  1899. procedure TDBCheckBox.SetValueCheck(const Value: string);
  1900. begin
  1901.   FValueCheck := Value;
  1902.   DataChange(Self);
  1903. end;
  1904.  
  1905. procedure TDBCheckBox.SetValueUncheck(const Value: string);
  1906. begin
  1907.   FValueUncheck := Value;
  1908.   DataChange(Self);
  1909. end;
  1910.  
  1911. procedure TDBCheckBox.WndProc(var Message: TMessage);
  1912. begin
  1913.   with Message do
  1914.     if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or
  1915.       (Msg = CM_TEXTCHANGED) or (Msg = CM_FONTCHANGED) then
  1916.       FPaintControl.DestroyHandle;
  1917.   inherited;
  1918. end;
  1919.  
  1920. procedure TDBCheckBox.WMPaint(var Message: TWMPaint);
  1921. begin
  1922.   if not (csPaintCopy in ControlState) then inherited else
  1923.   begin
  1924.     SendMessage(FPaintControl.Handle, BM_SETCHECK, Ord(GetFieldState), 0);
  1925.     SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  1926.   end;
  1927. end;
  1928.  
  1929. procedure TDBCheckBox.CMExit(var Message: TCMExit);
  1930. begin
  1931.   try
  1932.     FDataLink.UpdateRecord;
  1933.   except
  1934.     SetFocus;
  1935.     raise;
  1936.   end;
  1937.   inherited;
  1938. end;
  1939.  
  1940. procedure TDBCheckBox.CMGetDataLink(var Message: TMessage);
  1941. begin
  1942.   Message.Result := Integer(FDataLink);
  1943. end;
  1944.  
  1945. { TDBComboBox }
  1946.  
  1947. constructor TDBComboBox.Create(AOwner: TComponent);
  1948. begin
  1949.   inherited Create(AOwner);
  1950.   ControlStyle := ControlStyle + [csReplicatable];
  1951.   FDataLink := TFieldDataLink.Create(Self);
  1952.   FDataLink.OnDataChange := DataChange;
  1953.   FDataLink.OnUpdateData := UpdateData;
  1954.   FDataLink.OnEditingChange := EditingChange;
  1955.   FPaintControl := TPaintControl.Create(Self, 'COMBOBOX');
  1956. end;
  1957.  
  1958. destructor TDBComboBox.Destroy;
  1959. begin
  1960.   FPaintControl.Free;
  1961.   FDataLink.Free;
  1962.   FDataLink := nil;
  1963.   inherited Destroy;
  1964. end;
  1965.  
  1966. procedure TDBComboBox.Notification(AComponent: TComponent;
  1967.   Operation: TOperation);
  1968. begin
  1969.   inherited Notification(AComponent, Operation);
  1970.   if (Operation = opRemove) and (FDataLink <> nil) and
  1971.     (AComponent = DataSource) then DataSource := nil;
  1972. end;
  1973.  
  1974. procedure TDBComboBox.CreateWnd;
  1975. begin
  1976.   inherited CreateWnd;
  1977.   SetEditReadOnly;
  1978. end;
  1979.  
  1980. procedure TDBComboBox.DataChange(Sender: TObject);
  1981. begin
  1982.   if DroppedDown then Exit;
  1983.   if FDataLink.Field <> nil then
  1984.     SetComboText(FDataLink.Field.Text)
  1985.   else
  1986.     if csDesigning in ComponentState then
  1987.       SetComboText(Name)
  1988.     else
  1989.       SetComboText('');
  1990. end;
  1991.  
  1992. procedure TDBComboBox.UpdateData(Sender: TObject);
  1993. begin
  1994.   FDataLink.Field.Text := GetComboText;
  1995. end;
  1996.  
  1997. procedure TDBComboBox.SetComboText(const Value: string);
  1998. var
  1999.   I: Integer;
  2000.   Redraw: Boolean;
  2001. begin
  2002.   if Value <> GetComboText then
  2003.   begin
  2004.     if Style <> csDropDown then
  2005.     begin
  2006.       Redraw := (Style <> csSimple) and HandleAllocated;
  2007.       if Redraw then SendMessage(Handle, WM_SETREDRAW, 0, 0);
  2008.       try
  2009.         if Value = '' then I := -1 else I := Items.IndexOf(Value);
  2010.         ItemIndex := I;
  2011.       finally
  2012.         if Redraw then
  2013.         begin
  2014.           SendMessage(Handle, WM_SETREDRAW, 1, 0);
  2015.           Invalidate;
  2016.         end;
  2017.       end;
  2018.       if I >= 0 then Exit;
  2019.     end;
  2020.     if Style in [csDropDown, csSimple] then Text := Value;
  2021.   end;
  2022. end;
  2023.  
  2024. function TDBComboBox.GetComboText: string;
  2025. var
  2026.   I: Integer;
  2027. begin
  2028.   if Style in [csDropDown, csSimple] then Result := Text else
  2029.   begin
  2030.     I := ItemIndex;
  2031.     if I < 0 then Result := '' else Result := Items[I];
  2032.   end;
  2033. end;
  2034.  
  2035. procedure TDBComboBox.Change;
  2036. begin
  2037.   FDataLink.Edit;
  2038.   inherited Change;
  2039.   FDataLink.Modified;
  2040. end;
  2041.  
  2042. procedure TDBComboBox.Click;
  2043. begin
  2044.   FDataLink.Edit;
  2045.   inherited Click;
  2046.   FDataLink.Modified;
  2047. end;
  2048.  
  2049. procedure TDBComboBox.DropDown;
  2050. begin
  2051.   inherited DropDown;
  2052. end;
  2053.  
  2054. function TDBComboBox.GetDataSource: TDataSource;
  2055. begin
  2056.   Result := FDataLink.DataSource;
  2057. end;
  2058.  
  2059. procedure TDBComboBox.SetDataSource(Value: TDataSource);
  2060. begin
  2061.   FDataLink.DataSource := Value;
  2062.   if Value <> nil then Value.FreeNotification(Self);
  2063. end;
  2064.  
  2065. function TDBComboBox.GetDataField: string;
  2066. begin
  2067.   Result := FDataLink.FieldName;
  2068. end;
  2069.  
  2070. procedure TDBComboBox.SetDataField(const Value: string);
  2071. begin
  2072.   FDataLink.FieldName := Value;
  2073. end;
  2074.  
  2075. function TDBComboBox.GetReadOnly: Boolean;
  2076. begin
  2077.   Result := FDataLink.ReadOnly;
  2078. end;
  2079.  
  2080. procedure TDBComboBox.SetReadOnly(Value: Boolean);
  2081. begin
  2082.   FDataLink.ReadOnly := Value;
  2083. end;
  2084.  
  2085. function TDBComboBox.GetField: TField;
  2086. begin
  2087.   Result := FDataLink.Field;
  2088. end;
  2089.  
  2090. procedure TDBComboBox.KeyDown(var Key: Word; Shift: TShiftState);
  2091. begin
  2092.   inherited KeyDown(Key, Shift);
  2093.   if Key in [VK_BACK, VK_DELETE, VK_UP, VK_DOWN, 32..255] then
  2094.   begin
  2095.     if not FDataLink.Edit and (Key in [VK_UP, VK_DOWN]) then
  2096.       Key := 0;
  2097.   end;
  2098. end;
  2099.  
  2100. procedure TDBComboBox.KeyPress(var Key: Char);
  2101. begin
  2102.   inherited KeyPress(Key);
  2103.   if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
  2104.     not FDataLink.Field.IsValidChar(Key) then
  2105.   begin
  2106.     MessageBeep(0);
  2107.     Key := #0;
  2108.   end;
  2109.   case Key of
  2110.     ^H, ^V, ^X, #32..#255:
  2111.       FDataLink.Edit;
  2112.     #27:
  2113.       begin
  2114.         FDataLink.Reset;
  2115.         SelectAll;
  2116.         Key := #0;
  2117.       end;
  2118.   end;
  2119. end;
  2120.  
  2121. procedure TDBComboBox.EditingChange(Sender: TObject);
  2122. begin
  2123.   SetEditReadOnly;
  2124. end;
  2125.  
  2126. procedure TDBComboBox.SetEditReadOnly;
  2127. begin
  2128.   if (Style in [csDropDown, csSimple]) and HandleAllocated then
  2129.     SendMessage(EditHandle, EM_SETREADONLY, Ord(not FDataLink.Editing), 0);
  2130. end;
  2131.  
  2132. procedure TDBComboBox.WndProc(var Message: TMessage);
  2133. begin
  2134.   if not (csDesigning in ComponentState) then
  2135.     case Message.Msg of
  2136.       WM_COMMAND:
  2137.         if TWMCommand(Message).NotifyCode = CBN_SELCHANGE then
  2138.           if not FDataLink.Edit then
  2139.           begin
  2140.             if Style <> csSimple then
  2141.               PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0);
  2142.             Exit;
  2143.           end;
  2144.       CB_SHOWDROPDOWN:
  2145.         if Message.WParam <> 0 then FDataLink.Edit else
  2146.           if not FDataLink.Editing then DataChange(Self); {Restore text}
  2147.       WM_CREATE,
  2148.       WM_WINDOWPOSCHANGED,
  2149.       CM_FONTCHANGED:
  2150.         FPaintControl.DestroyHandle;
  2151.     end;
  2152.   inherited WndProc(Message);
  2153. end;
  2154.  
  2155. procedure TDBComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
  2156.   ComboProc: Pointer);
  2157. begin
  2158.   if not (csDesigning in ComponentState) then
  2159.     case Message.Msg of
  2160.       WM_LBUTTONDOWN:
  2161.         if (Style = csSimple) and (ComboWnd <> EditHandle) then
  2162.           if not FDataLink.Edit then Exit;
  2163.     end;
  2164.   inherited ComboWndProc(Message, ComboWnd, ComboProc);
  2165. end;
  2166.  
  2167. procedure TDBComboBox.CMExit(var Message: TCMExit);
  2168. begin
  2169.   try
  2170.     FDataLink.UpdateRecord;
  2171.   except
  2172.     SelectAll;
  2173.     SetFocus;
  2174.     raise;
  2175.   end;
  2176.   inherited;
  2177. end;
  2178.  
  2179. procedure TDBComboBox.WMPaint(var Message: TWMPaint);
  2180. var
  2181.   S: string;
  2182.   R: TRect;
  2183.   P: TPoint;
  2184.   Child: HWND;
  2185. begin
  2186.   if csPaintCopy in ControlState then
  2187.   begin
  2188.     if FDataLink.Field <> nil then S := FDataLink.Field.Text else S := '';
  2189.     if Style = csDropDown then
  2190.     begin
  2191.       SendMessage(FPaintControl.Handle, WM_SETTEXT, 0, Longint(PChar(S)));
  2192.       SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  2193.       Child := GetWindow(FPaintControl.Handle, GW_CHILD);
  2194.       if Child <> 0 then
  2195.       begin
  2196.         Windows.GetClientRect(Child, R);
  2197.         Windows.MapWindowPoints(Child, FPaintControl.Handle, R.TopLeft, 2);
  2198.         GetWindowOrgEx(Message.DC, P);
  2199.         SetWindowOrgEx(Message.DC, P.X - R.Left, P.Y - R.Top, nil);
  2200.         IntersectClipRect(Message.DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
  2201.         SendMessage(Child, WM_PAINT, Message.DC, 0);
  2202.       end;
  2203.     end else
  2204.     begin
  2205.       SendMessage(FPaintControl.Handle, CB_RESETCONTENT, 0, 0);
  2206.       if Items.IndexOf(S) <> -1 then
  2207.       begin
  2208.         SendMessage(FPaintControl.Handle, CB_ADDSTRING, 0, Longint(PChar(S)));
  2209.         SendMessage(FPaintControl.Handle, CB_SETCURSEL, 0, 0);
  2210.       end;
  2211.       SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  2212.     end;
  2213.   end else
  2214.     inherited;
  2215. end;
  2216.  
  2217. procedure TDBComboBox.SetItems(Value: TStrings);
  2218. begin
  2219.   Items.Assign(Value);
  2220.   DataChange(Self);
  2221. end;
  2222.  
  2223. procedure TDBCombobox.SetStyle(Value: TComboboxStyle);
  2224. begin
  2225.   if (Value = csSimple) and Assigned(FDatalink) and FDatalink.DatasourceFixed then
  2226.     DatabaseError(SNotReplicatable);
  2227.   inherited SetStyle(Value);
  2228. end;
  2229.  
  2230. procedure TDBCombobox.CMGetDatalink(var Message: TMessage);
  2231. begin
  2232.   Message.Result := Integer(FDataLink);
  2233. end;
  2234.  
  2235.  
  2236. { TDBListBox }
  2237.  
  2238. constructor TDBListBox.Create(AOwner: TComponent);
  2239. begin
  2240.   inherited Create(AOwner);
  2241.   FDataLink := TFieldDataLink.Create(Self);
  2242.   FDataLink.OnDataChange := DataChange;
  2243.   FDataLink.OnUpdateData := UpdateData;
  2244. end;
  2245.  
  2246. destructor TDBListBox.Destroy;
  2247. begin
  2248.   FDataLink.Free;
  2249.   FDataLink := nil;
  2250.   inherited Destroy;
  2251. end;
  2252.  
  2253. procedure TDBListBox.Notification(AComponent: TComponent;
  2254.   Operation: TOperation);
  2255. begin
  2256.   inherited Notification(AComponent, Operation);
  2257.   if (Operation = opRemove) and (FDataLink <> nil) and
  2258.     (AComponent = DataSource) then DataSource := nil;
  2259. end;
  2260.  
  2261. procedure TDBListBox.DataChange(Sender: TObject);
  2262. begin
  2263.   if FDataLink.Field <> nil then
  2264.     ItemIndex := Items.IndexOf(FDataLink.Field.Text) else
  2265.     ItemIndex := -1;
  2266. end;
  2267.  
  2268. procedure TDBListBox.UpdateData(Sender: TObject);
  2269. begin
  2270.   if ItemIndex >= 0 then
  2271.     FDataLink.Field.Text := Items[ItemIndex] else
  2272.     FDataLink.Field.Text := '';
  2273. end;
  2274.  
  2275. procedure TDBListBox.Click;
  2276. begin
  2277.   if FDataLink.Edit then
  2278.   begin
  2279.     inherited Click;
  2280.     FDataLink.Modified;
  2281.   end;
  2282. end;
  2283.  
  2284. function TDBListBox.GetDataSource: TDataSource;
  2285. begin
  2286.   Result := FDataLink.DataSource;
  2287. end;
  2288.  
  2289. procedure TDBListBox.SetDataSource(Value: TDataSource);
  2290. begin
  2291.   FDataLink.DataSource := Value;
  2292.   if Value <> nil then Value.FreeNotification(Self);
  2293. end;
  2294.  
  2295. function TDBListBox.GetDataField: string;
  2296. begin
  2297.   Result := FDataLink.FieldName;
  2298. end;
  2299.  
  2300. procedure TDBListBox.SetDataField(const Value: string);
  2301. begin
  2302.   FDataLink.FieldName := Value;
  2303. end;
  2304.  
  2305. function TDBListBox.GetReadOnly: Boolean;
  2306. begin
  2307.   Result := FDataLink.ReadOnly;
  2308. end;
  2309.  
  2310. procedure TDBListBox.SetReadOnly(Value: Boolean);
  2311. begin
  2312.   FDataLink.ReadOnly := Value;
  2313. end;
  2314.  
  2315. function TDBListBox.GetField: TField;
  2316. begin
  2317.   Result := FDataLink.Field;
  2318. end;
  2319.  
  2320. procedure TDBListBox.KeyDown(var Key: Word; Shift: TShiftState);
  2321. begin
  2322.   inherited KeyDown(Key, Shift);
  2323.   if Key in [VK_PRIOR, VK_NEXT, VK_END, VK_HOME, VK_LEFT, VK_UP,
  2324.     VK_RIGHT, VK_DOWN] then
  2325.     if not FDataLink.Edit then Key := 0;
  2326. end;
  2327.  
  2328. procedure TDBListBox.KeyPress(var Key: Char);
  2329. begin
  2330.   inherited KeyPress(Key);
  2331.   case Key of
  2332.     #32..#255:
  2333.       if not FDataLink.Edit then Key := #0;
  2334.     #27:
  2335.       FDataLink.Reset;
  2336.   end;
  2337. end;
  2338.  
  2339. procedure TDBListBox.WMLButtonDown(var Message: TWMLButtonDown);
  2340. begin
  2341.   if FDataLink.Edit then inherited
  2342.   else
  2343.   begin
  2344.     SetFocus;
  2345.     with Message do
  2346.       MouseDown(mbLeft, KeysToShiftState(Keys), XPos, YPos);
  2347.   end;
  2348. end;
  2349.  
  2350. procedure TDBListBox.CMExit(var Message: TCMExit);
  2351. begin
  2352.   try
  2353.     FDataLink.UpdateRecord;
  2354.   except
  2355.     SetFocus;
  2356.     raise;
  2357.   end;
  2358.   inherited;
  2359. end;
  2360.  
  2361. procedure TDBListBox.SetItems(Value: TStrings);
  2362. begin
  2363.   Items.Assign(Value);
  2364.   DataChange(Self);
  2365. end;
  2366.  
  2367. { TDBRadioGroup }
  2368.  
  2369. constructor TDBRadioGroup.Create(AOwner: TComponent);
  2370. begin
  2371.   inherited Create(AOwner);
  2372.   FDataLink := TFieldDataLink.Create(Self);
  2373.   FDataLink.OnDataChange := DataChange;
  2374.   FDataLink.OnUpdateData := UpdateData;
  2375.   FValues := TStringList.Create;
  2376. end;
  2377.  
  2378. destructor TDBRadioGroup.Destroy;
  2379. begin
  2380.   FDataLink.Free;
  2381.   FDataLink := nil;
  2382.   FValues.Free;
  2383.   inherited Destroy;
  2384. end;
  2385.  
  2386. procedure TDBRadioGroup.Notification(AComponent: TComponent;
  2387.   Operation: TOperation);
  2388. begin
  2389.   inherited Notification(AComponent, Operation);
  2390.   if (Operation = opRemove) and (FDataLink <> nil) and
  2391.     (AComponent = DataSource) then DataSource := nil;
  2392. end;
  2393.  
  2394. procedure TDBRadioGroup.DataChange(Sender: TObject);
  2395. begin
  2396.   if FDataLink.Field <> nil then
  2397.     Value := FDataLink.Field.Text else
  2398.     Value := '';
  2399. end;
  2400.  
  2401. procedure TDBRadioGroup.UpdateData(Sender: TObject);
  2402. begin
  2403.   if FDataLink.Field <> nil then FDataLink.Field.Text := Value;
  2404. end;
  2405.  
  2406. function TDBRadioGroup.GetDataSource: TDataSource;
  2407. begin
  2408.   Result := FDataLink.DataSource;
  2409. end;
  2410.  
  2411. procedure TDBRadioGroup.SetDataSource(Value: TDataSource);
  2412. begin
  2413.   FDataLink.DataSource := Value;
  2414.   if Value <> nil then Value.FreeNotification(Self);
  2415. end;
  2416.  
  2417. function TDBRadioGroup.GetDataField: string;
  2418. begin
  2419.   Result := FDataLink.FieldName;
  2420. end;
  2421.  
  2422. procedure TDBRadioGroup.SetDataField(const Value: string);
  2423. begin
  2424.   FDataLink.FieldName := Value;
  2425. end;
  2426.  
  2427. function TDBRadioGroup.GetReadOnly: Boolean;
  2428. begin
  2429.   Result := FDataLink.ReadOnly;
  2430. end;
  2431.  
  2432. procedure TDBRadioGroup.SetReadOnly(Value: Boolean);
  2433. begin
  2434.   FDataLink.ReadOnly := Value;
  2435. end;
  2436.  
  2437. function TDBRadioGroup.GetField: TField;
  2438. begin
  2439.   Result := FDataLink.Field;
  2440. end;
  2441.  
  2442. function TDBRadioGroup.GetButtonValue(Index: Integer): string;
  2443. begin
  2444.   if (Index < FValues.Count) and (FValues[Index] <> '') then
  2445.     Result := FValues[Index]
  2446.   else if Index < Items.Count then
  2447.     Result := Items[Index]
  2448.   else
  2449.     Result := '';
  2450. end;
  2451.  
  2452. procedure TDBRadioGroup.SetValue(const Value: string);
  2453. var
  2454.   I, Index: Integer;
  2455. begin
  2456.   if FValue <> Value then
  2457.   begin
  2458.     FInSetValue := True;
  2459.     try
  2460.       Index := -1;
  2461.       for I := 0 to Items.Count - 1 do
  2462.         if Value = GetButtonValue(I) then
  2463.         begin
  2464.           Index := I;
  2465.           Break;
  2466.         end;
  2467.       ItemIndex := Index;
  2468.     finally
  2469.       FInSetValue := False;
  2470.     end;
  2471.     FValue := Value;
  2472.     Change;
  2473.   end;
  2474. end;
  2475.  
  2476. procedure TDBRadioGroup.CMExit(var Message: TCMExit);
  2477. begin
  2478.   try
  2479.     FDataLink.UpdateRecord;
  2480.   except
  2481.     if ItemIndex >= 0 then
  2482.       TRadioButton(Controls[ItemIndex]).SetFocus else
  2483.       TRadioButton(Controls[0]).SetFocus;
  2484.     raise;
  2485.   end;
  2486.   inherited;
  2487. end;
  2488.  
  2489. procedure TDBRadioGroup.Click;
  2490. begin
  2491.   if not FInSetValue then
  2492.   begin
  2493.     inherited Click;
  2494.     if ItemIndex >= 0 then Value := GetButtonValue(ItemIndex);
  2495.     if FDataLink.Editing then FDataLink.Modified;
  2496.   end;
  2497. end;
  2498.  
  2499. procedure TDBRadioGroup.SetItems(Value: TStrings);
  2500. begin
  2501.   Items.Assign(Value);
  2502.   DataChange(Self);
  2503. end;
  2504.  
  2505. procedure TDBRadioGroup.SetValues(Value: TStrings);
  2506. begin
  2507.   FValues.Assign(Value);
  2508.   DataChange(Self);
  2509. end;
  2510.  
  2511. procedure TDBRadioGroup.Change;
  2512. begin
  2513.   if Assigned(FOnChange) then FOnChange(Self);
  2514. end;
  2515.  
  2516. procedure TDBRadioGroup.KeyPress(var Key: Char);
  2517. begin
  2518.   inherited KeyPress(Key);
  2519.   case Key of
  2520.     #8, ' ': FDataLink.Edit;
  2521.     #27: FDataLink.Reset;
  2522.   end;
  2523. end;
  2524.  
  2525. function TDBRadioGroup.CanModify: Boolean;
  2526. begin
  2527.   Result := FDataLink.Edit;
  2528. end;
  2529.  
  2530. { TDBMemo }
  2531.  
  2532. constructor TDBMemo.Create(AOwner: TComponent);
  2533. begin
  2534.   inherited Create(AOwner);
  2535.   inherited ReadOnly := True;
  2536.   ControlStyle := ControlStyle + [csReplicatable];
  2537.   FAutoDisplay := True;
  2538.   FDataLink := TFieldDataLink.Create(Self);
  2539.   FDataLink.OnDataChange := DataChange;
  2540.   FDataLink.OnEditingChange := EditingChange;
  2541.   FDataLink.OnUpdateData := UpdateData;
  2542.   FPaintControl := TPaintControl.Create(Self, 'EDIT');
  2543. end;
  2544.  
  2545. destructor TDBMemo.Destroy;
  2546. begin
  2547.   FPaintControl.Free;
  2548.   FDataLink.Free;
  2549.   FDataLink := nil;
  2550.   inherited Destroy;
  2551. end;
  2552.  
  2553. procedure TDBMemo.Notification(AComponent: TComponent;
  2554.   Operation: TOperation);
  2555. begin
  2556.   inherited Notification(AComponent, Operation);
  2557.   if (Operation = opRemove) and (FDataLink <> nil) and
  2558.     (AComponent = DataSource) then DataSource := nil;
  2559. end;
  2560.  
  2561. procedure TDBMemo.KeyDown(var Key: Word; Shift: TShiftState);
  2562. begin
  2563.   inherited KeyDown(Key, Shift);
  2564.   if FMemoLoaded then
  2565.   begin
  2566.     if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then
  2567.       FDataLink.Edit;
  2568.   end;
  2569. end;
  2570.  
  2571. procedure TDBMemo.KeyPress(var Key: Char);
  2572. begin
  2573.   inherited KeyPress(Key);
  2574.   if FMemoLoaded then
  2575.   begin
  2576.     if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
  2577.       not FDataLink.Field.IsValidChar(Key) then
  2578.     begin
  2579.       MessageBeep(0);
  2580.       Key := #0;
  2581.     end;
  2582.     case Key of
  2583.       ^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
  2584.         FDataLink.Edit;
  2585.       #27:
  2586.         FDataLink.Reset;
  2587.     end;
  2588.   end else
  2589.   begin
  2590.     if Key = #13 then LoadMemo;
  2591.     Key := #0;
  2592.   end;
  2593. end;
  2594.  
  2595. procedure TDBMemo.Change;
  2596. begin
  2597.   if FMemoLoaded then FDataLink.Modified;
  2598.   FMemoLoaded := True;
  2599.   inherited Change;
  2600. end;
  2601.  
  2602. function TDBMemo.GetDataSource: TDataSource;
  2603. begin
  2604.   Result := FDataLink.DataSource;
  2605. end;
  2606.  
  2607. procedure TDBMemo.SetDataSource(Value: TDataSource);
  2608. begin
  2609.   FDataLink.DataSource := Value;
  2610.   if Value <> nil then Value.FreeNotification(Self);
  2611. end;
  2612.  
  2613. function TDBMemo.GetDataField: string;
  2614. begin
  2615.   Result := FDataLink.FieldName;
  2616. end;
  2617.  
  2618. procedure TDBMemo.SetDataField(const Value: string);
  2619. begin
  2620.   FDataLink.FieldName := Value;
  2621. end;
  2622.  
  2623. function TDBMemo.GetReadOnly: Boolean;
  2624. begin
  2625.   Result := FDataLink.ReadOnly;
  2626. end;
  2627.  
  2628. procedure TDBMemo.SetReadOnly(Value: Boolean);
  2629. begin
  2630.   FDataLink.ReadOnly := Value;
  2631. end;
  2632.  
  2633. function TDBMemo.GetField: TField;
  2634. begin
  2635.   Result := FDataLink.Field;
  2636. end;
  2637.  
  2638. procedure TDBMemo.LoadMemo;
  2639. begin
  2640.   if not FMemoLoaded and Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
  2641.   begin
  2642.     try
  2643.       Lines.Text := FDataLink.Field.AsString;
  2644.       FMemoLoaded := True;
  2645.     except
  2646.       { Memo too large }
  2647.       on E:EInvalidOperation do
  2648.         Lines.Text := Format('(%s)', [E.Message]);
  2649.     end;
  2650.     EditingChange(Self);
  2651.   end;
  2652. end;
  2653.  
  2654. procedure TDBMemo.DataChange(Sender: TObject);
  2655. begin
  2656.   if FDataLink.Field <> nil then
  2657.     if FDataLink.Field.IsBlob then
  2658.     begin
  2659.       if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then
  2660.       begin
  2661.         FMemoLoaded := False;
  2662.         LoadMemo;
  2663.       end else
  2664.       begin
  2665.         Text := Format('(%s)', [FDataLink.Field.DisplayLabel]);
  2666.         FMemoLoaded := False;
  2667.       end;
  2668.     end else
  2669.     begin
  2670.       if FFocused and FDataLink.CanModify then
  2671.         Text := FDataLink.Field.Text
  2672.       else
  2673.         Text := FDataLink.Field.DisplayText;
  2674.       FMemoLoaded := True;
  2675.     end
  2676.   else
  2677.   begin
  2678.     if csDesigning in ComponentState then Text := Name else Text := '';
  2679.     FMemoLoaded := False;
  2680.   end;
  2681.   if HandleAllocated then
  2682.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
  2683. end;
  2684.  
  2685. procedure TDBMemo.EditingChange(Sender: TObject);
  2686. begin
  2687.   inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded);
  2688. end;
  2689.  
  2690. procedure TDBMemo.UpdateData(Sender: TObject);
  2691. begin
  2692.   FDataLink.Field.AsString := Text;
  2693. end;
  2694.  
  2695. procedure TDBMemo.SetFocused(Value: Boolean);
  2696. begin
  2697.   if FFocused <> Value then
  2698.   begin
  2699.     FFocused := Value;
  2700.     if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then
  2701.       FDataLink.Reset;
  2702.   end;
  2703. end;
  2704.  
  2705. procedure TDBMemo.WndProc(var Message: TMessage);
  2706. begin
  2707.   with Message do
  2708.     if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or
  2709.       (Msg = CM_FONTCHANGED) then FPaintControl.DestroyHandle;
  2710.   inherited;
  2711. end;
  2712.  
  2713. procedure TDBMemo.CMEnter(var Message: TCMEnter);
  2714. begin
  2715.   SetFocused(True);
  2716.   inherited;
  2717. end;
  2718.  
  2719. procedure TDBMemo.CMExit(var Message: TCMExit);
  2720. begin
  2721.   try
  2722.     FDataLink.UpdateRecord;
  2723.   except
  2724.     SetFocus;
  2725.     raise;
  2726.   end;
  2727.   SetFocused(False);
  2728.   inherited;
  2729. end;
  2730.  
  2731. procedure TDBMemo.SetAutoDisplay(Value: Boolean);
  2732. begin
  2733.   if FAutoDisplay <> Value then
  2734.   begin
  2735.     FAutoDisplay := Value;
  2736.     if Value then LoadMemo;
  2737.   end;
  2738. end;
  2739.  
  2740. procedure TDBMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  2741. begin
  2742.   if not FMemoLoaded then LoadMemo else inherited;
  2743. end;
  2744.  
  2745. procedure TDBMemo.WMCut(var Message: TMessage);
  2746. begin
  2747.   FDataLink.Edit;
  2748.   inherited;
  2749. end;
  2750.  
  2751. procedure TDBMemo.WMPaste(var Message: TMessage);
  2752. begin
  2753.   FDataLink.Edit;
  2754.   inherited;
  2755. end;
  2756.  
  2757. procedure TDBMemo.CMGetDataLink(var Message: TMessage);
  2758. begin
  2759.   Message.Result := Integer(FDataLink);
  2760. end;
  2761.  
  2762. procedure TDBMemo.WMPaint(var Message: TWMPaint);
  2763. var
  2764.   S: string;
  2765. begin
  2766.   if not (csPaintCopy in ControlState) then inherited else
  2767.   begin
  2768.     if FDataLink.Field <> nil then
  2769.       if FDataLink.Field.IsBlob then
  2770.       begin
  2771.         if FAutoDisplay then
  2772.           S := AdjustLineBreaks(FDataLink.Field.AsString) else
  2773.           S := Format('(%s)', [FDataLink.Field.DisplayLabel]);
  2774.       end else
  2775.         S := FDataLink.Field.DisplayText;
  2776.     SendMessage(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PChar(S)));
  2777.     SendMessage(FPaintControl.Handle, WM_ERASEBKGND, Message.DC, 0);
  2778.     SendMessage(FPaintControl.Handle, WM_PAINT, Message.DC, 0);
  2779.   end;
  2780. end;
  2781.  
  2782. { TDBImage }
  2783.  
  2784. constructor TDBImage.Create(AOwner: TComponent);
  2785. begin
  2786.   inherited Create(AOwner);
  2787.   ControlStyle := ControlStyle + [csOpaque, csReplicatable];
  2788.   if not NewStyleControls then ControlStyle := ControlStyle + [csFramed];
  2789.   Width := 105;
  2790.   Height := 105;
  2791.   TabStop := True;
  2792.   ParentColor := False;
  2793.   FPicture := TPicture.Create;
  2794.   FPicture.OnChange := PictureChanged;
  2795.   FBorderStyle := bsSingle;
  2796.   FAutoDisplay := True;
  2797.   FCenter := True;
  2798.   FDataLink := TFieldDataLink.Create(Self);
  2799.   FDataLink.OnDataChange := DataChange;
  2800.   FDataLink.OnUpdateData := UpdateData;
  2801.   FQuickDraw := True;
  2802. end;
  2803.  
  2804. destructor TDBImage.Destroy;
  2805. begin
  2806.   FPicture.Free;
  2807.   FDataLink.Free;
  2808.   FDataLink := nil;
  2809.   inherited Destroy;
  2810. end;
  2811.  
  2812. function TDBImage.GetDataSource: TDataSource;
  2813. begin
  2814.   Result := FDataLink.DataSource;
  2815. end;
  2816.  
  2817. procedure TDBImage.SetDataSource(Value: TDataSource);
  2818. begin
  2819.   FDataLink.DataSource := Value;
  2820.   if Value <> nil then Value.FreeNotification(Self);
  2821. end;
  2822.  
  2823. function TDBImage.GetDataField: string;
  2824. begin
  2825.   Result := FDataLink.FieldName;
  2826. end;
  2827.  
  2828. procedure TDBImage.SetDataField(const Value: string);
  2829. begin
  2830.   FDataLink.FieldName := Value;
  2831. end;
  2832.  
  2833. function TDBImage.GetReadOnly: Boolean;
  2834. begin
  2835.   Result := FDataLink.ReadOnly;
  2836. end;
  2837.  
  2838. procedure TDBImage.SetReadOnly(Value: Boolean);
  2839. begin
  2840.   FDataLink.ReadOnly := Value;
  2841. end;
  2842.  
  2843. function TDBImage.GetField: TField;
  2844. begin
  2845.   Result := FDataLink.Field;
  2846. end;
  2847.  
  2848. function TDBImage.GetPalette: HPALETTE;
  2849. begin
  2850.   Result := 0;
  2851.   if FPicture.Graphic is TBitmap then
  2852.     Result := TBitmap(FPicture.Graphic).Palette;
  2853. end;
  2854.  
  2855. procedure TDBImage.SetAutoDisplay(Value: Boolean);
  2856. begin
  2857.   if FAutoDisplay <> Value then
  2858.   begin
  2859.     FAutoDisplay := Value;
  2860.     if Value then LoadPicture;
  2861.   end;
  2862. end;
  2863.  
  2864. procedure TDBImage.SetBorderStyle(Value: TBorderStyle);
  2865. begin
  2866.   if FBorderStyle <> Value then
  2867.   begin
  2868.     FBorderStyle := Value;
  2869.     RecreateWnd;
  2870.   end;
  2871. end;
  2872.  
  2873. procedure TDBImage.SetCenter(Value: Boolean);
  2874. begin
  2875.   if FCenter <> Value then
  2876.   begin
  2877.     FCenter := Value;
  2878.     Invalidate;
  2879.   end;
  2880. end;
  2881.  
  2882. procedure TDBImage.SetPicture(Value: TPicture);
  2883. begin
  2884.   FPicture.Assign(Value);
  2885. end;
  2886.  
  2887. procedure TDBImage.SetStretch(Value: Boolean);
  2888. begin
  2889.   if FStretch <> Value then
  2890.   begin
  2891.     FStretch := Value;
  2892.     Invalidate;
  2893.   end;
  2894. end;
  2895.  
  2896. procedure TDBImage.Paint;
  2897. var
  2898.   W, H: Integer;
  2899.   R: TRect;
  2900.   S: string;
  2901.   DrawPict: TPicture;
  2902. begin
  2903.   with Canvas do
  2904.   begin
  2905.     Brush.Style := bsSolid;
  2906.     Brush.Color := Color;
  2907.     if FPictureLoaded or (csPaintCopy in ControlState) then
  2908.     begin
  2909.       DrawPict := TPicture.Create;
  2910.       H := 0;
  2911.       try
  2912.         if (csPaintCopy in ControlState) and
  2913.           Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
  2914.         begin
  2915.           DrawPict.Assign(FDataLink.Field);
  2916.           if DrawPict.Graphic is TBitmap then
  2917.             DrawPict.Bitmap.IgnorePalette := QuickDraw;
  2918.         end
  2919.         else
  2920.         begin
  2921.           DrawPict.Assign(Picture);
  2922.           if Focused and (DrawPict.Graphic is TBitmap) and
  2923.             (DrawPict.Bitmap.Palette <> 0) then
  2924.           begin { Control has focus, so realize the bitmap palette in foreground }
  2925.             H := SelectPalette(Handle, DrawPict.Bitmap.Palette, False);
  2926.             RealizePalette(Handle);
  2927.           end;
  2928.         end;
  2929.         if Stretch then
  2930.           if (DrawPict.Graphic = nil) or DrawPict.Graphic.Empty then
  2931.             FillRect(ClientRect)
  2932.           else
  2933.             StretchDraw(ClientRect, DrawPict.Graphic)
  2934.         else
  2935.         begin
  2936.           SetRect(R, 0, 0, DrawPict.Width, DrawPict.Height);
  2937.           if Center then OffsetRect(R, (ClientWidth - DrawPict.Width) div 2,
  2938.             (ClientHeight - DrawPict.Height) div 2);
  2939.           StretchDraw(R, DrawPict.Graphic);
  2940.           ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  2941.           FillRect(ClientRect);
  2942.           SelectClipRgn(Handle, 0);
  2943.         end;
  2944.       finally
  2945.         if H <> 0 then SelectPalette(Handle, H, True);
  2946.         DrawPict.Free;
  2947.       end;
  2948.     end
  2949.     else begin
  2950.       Font := Self.Font;
  2951.       if FDataLink.Field <> nil then
  2952.         S := FDataLink.Field.DisplayLabel
  2953.       else S := Name;
  2954.       S := '(' + S + ')';
  2955.       W := TextWidth(S);
  2956.       H := TextHeight(S);
  2957.       R := ClientRect;
  2958.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  2959.     end;
  2960.     if (GetParentForm(Self).ActiveControl = Self) and
  2961.       not (csDesigning in ComponentState) and
  2962.       not (csPaintCopy in ControlState) then
  2963.     begin
  2964.       Brush.Color := clWindowFrame;
  2965.       FrameRect(ClientRect);
  2966.     end;
  2967.   end;
  2968. end;
  2969.  
  2970. procedure TDBImage.PictureChanged(Sender: TObject);
  2971. begin
  2972.   FDataLink.Modified;
  2973.   FPictureLoaded := True;
  2974.   Invalidate;
  2975. end;
  2976.  
  2977. procedure TDBImage.Notification(AComponent: TComponent;
  2978.   Operation: TOperation);
  2979. begin
  2980.   inherited Notification(AComponent, Operation);
  2981.   if (Operation = opRemove) and (FDataLink <> nil) and
  2982.     (AComponent = DataSource) then DataSource := nil;
  2983. end;
  2984.  
  2985. procedure TDBImage.LoadPicture;
  2986. begin
  2987.   if not FPictureLoaded and (not Assigned(FDataLink.Field) or
  2988.     FDataLink.Field.IsBlob) then
  2989.     Picture.Assign(FDataLink.Field);
  2990. end;
  2991.  
  2992. procedure TDBImage.DataChange(Sender: TObject);
  2993. begin
  2994.   Picture.Graphic := nil;
  2995.   FPictureLoaded := False;
  2996.   if FAutoDisplay then LoadPicture;
  2997. end;
  2998.  
  2999. procedure TDBImage.UpdateData(Sender: TObject);
  3000. begin
  3001.   if Picture.Graphic is TBitmap then
  3002.      FDataLink.Field.Assign(Picture.Graphic) else
  3003.      FDataLink.Field.Clear;
  3004. end;
  3005.  
  3006. procedure TDBImage.CopyToClipboard;
  3007. begin
  3008.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  3009. end;
  3010.  
  3011. procedure TDBImage.CutToClipboard;
  3012. begin
  3013.   if Picture.Graphic <> nil then
  3014.     if FDataLink.Edit then
  3015.     begin
  3016.       CopyToClipboard;
  3017.       Picture.Graphic := nil;
  3018.     end;
  3019. end;
  3020.  
  3021. procedure TDBImage.PasteFromClipboard;
  3022. begin
  3023.   if Clipboard.HasFormat(CF_BITMAP) and FDataLink.Edit then
  3024.     Picture.Bitmap.Assign(Clipboard);
  3025. end;
  3026.  
  3027. procedure TDBImage.CreateParams(var Params: TCreateParams);
  3028. begin
  3029.   inherited CreateParams(Params);
  3030.   with Params do
  3031.   begin
  3032.     if FBorderStyle = bsSingle then
  3033.       if NewStyleControls and Ctl3D then
  3034.         ExStyle := ExStyle or WS_EX_CLIENTEDGE
  3035.       else
  3036.         Style := Style or WS_BORDER;
  3037.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  3038.   end;
  3039. end;
  3040.  
  3041. procedure TDBImage.KeyDown(var Key: Word; Shift: TShiftState);
  3042. begin
  3043.   inherited KeyDown(Key, Shift);
  3044.   case Key of
  3045.     VK_INSERT:
  3046.       if ssShift in Shift then PasteFromClipBoard else
  3047.         if ssCtrl in Shift then CopyToClipBoard;
  3048.     VK_DELETE:
  3049.       if ssShift in Shift then CutToClipBoard;
  3050.   end;
  3051. end;
  3052.  
  3053. procedure TDBImage.KeyPress(var Key: Char);
  3054. begin
  3055.   inherited KeyPress(Key);
  3056.   case Key of
  3057.     ^X: CutToClipBoard;
  3058.     ^C: CopyToClipBoard;
  3059.     ^V: PasteFromClipBoard;
  3060.     #13: LoadPicture;
  3061.     #27: FDataLink.Reset;
  3062.   end;
  3063. end;
  3064.  
  3065. procedure TDBImage.CMEnter(var Message: TCMEnter);
  3066. begin
  3067.   Invalidate; { Draw the focus marker }
  3068.   inherited;
  3069. end;
  3070.  
  3071. procedure TDBImage.CMExit(var Message: TCMExit);
  3072. begin
  3073.   Invalidate; { Erase the focus marker }
  3074.   inherited;
  3075. end;
  3076.  
  3077. procedure TDBImage.CMTextChanged(var Message: TMessage);
  3078. begin
  3079.   inherited;
  3080.   if not FPictureLoaded then Invalidate;
  3081. end;
  3082.  
  3083. procedure TDBImage.WMLButtonDown(var Message: TWMLButtonDown);
  3084. begin
  3085.   if TabStop and CanFocus then SetFocus;
  3086.   inherited;
  3087. end;
  3088.  
  3089. procedure TDBImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  3090. begin
  3091.   LoadPicture;
  3092.   inherited;
  3093. end;
  3094.  
  3095. procedure TDBImage.WMCut(var Message: TMessage);
  3096. begin
  3097.   CutToClipboard;
  3098. end;
  3099.  
  3100. procedure TDBImage.WMCopy(var Message: TMessage);
  3101. begin
  3102.   CopyToClipboard;
  3103. end;
  3104.  
  3105. procedure TDBImage.WMPaste(var Message: TMessage);
  3106. begin
  3107.   PasteFromClipboard;
  3108. end;
  3109.  
  3110. procedure TDBImage.WMSize(var Message: TMessage);
  3111. begin
  3112.   inherited;
  3113.   Invalidate;
  3114. end;
  3115.  
  3116. { TDBNavigator }
  3117.  
  3118. // !!! convert to an array of pointers to the resourcestring records.
  3119.  
  3120. var
  3121.   BtnTypeName: array[TNavigateBtn] of PChar = ('FIRST', 'PRIOR', 'NEXT',
  3122.     'LAST', 'INSERT', 'DELETE', 'EDIT', 'POST', 'CANCEL', 'REFRESH');
  3123.   BtnHintId: array[TNavigateBtn] of string = (SFirstRecord, SPriorRecord,
  3124.     SNextRecord, SLastRecord, SInsertRecord, SDeleteRecord, SEditRecord,
  3125.     SPostEdit, SCancelEdit, SRefreshRecord);
  3126.  
  3127. constructor TDBNavigator.Create(AOwner: TComponent);
  3128. begin
  3129.   inherited Create(AOwner);
  3130.   ControlStyle := ControlStyle - [csAcceptsControls, csSetCaption] + [csOpaque];
  3131.   if not NewStyleControls then ControlStyle := ControlStyle + [csFramed];
  3132.   FDataLink := TNavDataLink.Create(Self);
  3133.   FVisibleButtons := [nbFirst, nbPrior, nbNext, nbLast, nbInsert,
  3134.     nbDelete, nbEdit, nbPost, nbCancel, nbRefresh];
  3135.   FHints := TStringList.Create;
  3136.   InitButtons;
  3137.   BevelOuter := bvNone;
  3138.   BevelInner := bvNone;
  3139.   Width := 241;
  3140.   Height := 25;
  3141.   ButtonWidth := 0;
  3142.   FocusedButton := nbFirst;
  3143.   FConfirmDelete := True;
  3144.   FullRepaint := False;
  3145. end;
  3146.  
  3147. destructor TDBNavigator.Destroy;
  3148. begin
  3149.   FDataLink.Free;
  3150.   FHints.Free;
  3151.   FDataLink := nil;
  3152.   inherited Destroy;
  3153. end;
  3154.  
  3155. procedure TDBNavigator.InitButtons;
  3156. var
  3157.   I: TNavigateBtn;
  3158.   Btn: TNavButton;
  3159.   X: Integer;
  3160.   ResName: string;
  3161. begin
  3162.   MinBtnSize := Point(20, 18);
  3163.   X := 0;
  3164.   for I := Low(Buttons) to High(Buttons) do
  3165.   begin
  3166.     Btn := TNavButton.Create (Self);
  3167.     Btn.Flat := Flat;
  3168.     Btn.Index := I;
  3169.     Btn.Visible := I in FVisibleButtons;
  3170.     Btn.Enabled := True;
  3171.     Btn.SetBounds (X, 0, MinBtnSize.X, MinBtnSize.Y);
  3172.     FmtStr(ResName, 'dbn_%s', [BtnTypeName[I]]);
  3173.     Btn.Glyph.LoadFromResourceName(HInstance, ResName);
  3174.     Btn.NumGlyphs := 2;
  3175.     Btn.Enabled := False;  {!DT?: Force creation of speedbutton images}
  3176.     Btn.Enabled := True;
  3177.     Btn.OnClick := ClickHandler;
  3178.     Btn.OnMouseDown := BtnMouseDown;
  3179.     Btn.Parent := Self;
  3180.     Buttons[I] := Btn;
  3181.     X := X + MinBtnSize.X;
  3182.   end;
  3183.   InitHints;
  3184.   Buttons[nbPrior].NavStyle := Buttons[nbPrior].NavStyle + [nsAllowTimer];
  3185.   Buttons[nbNext].NavStyle  := Buttons[nbNext].NavStyle + [nsAllowTimer];
  3186. end;
  3187.  
  3188. procedure TDBNavigator.InitHints;
  3189. var
  3190.   I: Integer;
  3191.   J: TNavigateBtn;
  3192. begin
  3193.   for J := Low(Buttons) to High(Buttons) do
  3194.     Buttons[J].Hint := BtnHintId[J];
  3195.   J := Low(Buttons);
  3196.   for I := 0 to (FHints.Count - 1) do
  3197.   begin
  3198.     if FHints.Strings[I] <> '' then Buttons[J].Hint := FHints.Strings[I];
  3199.     if J = High(Buttons) then Exit;
  3200.     Inc(J);
  3201.   end;
  3202. end;
  3203.  
  3204. procedure TDBNavigator.SetFlat(Value: Boolean);
  3205. var
  3206.   I: TNavigateBtn;
  3207. begin
  3208.   if FFlat <> Value then
  3209.   begin
  3210.     FFlat := Value;
  3211.     for I := Low(Buttons) to High(Buttons) do
  3212.       Buttons[I].Flat := Value;
  3213.   end;
  3214. end;
  3215.  
  3216. procedure TDBNavigator.SetHints(Value: TStrings);
  3217. begin
  3218.   FHints.Assign(Value);
  3219.   InitHints;
  3220. end;
  3221.  
  3222. procedure TDBNavigator.GetChildren(Proc: TGetChildProc; Root: TComponent);
  3223. begin
  3224. end;
  3225.  
  3226. procedure TDBNavigator.Notification(AComponent: TComponent;
  3227.   Operation: TOperation);
  3228. begin
  3229.   inherited Notification(AComponent, Operation);
  3230.   if (Operation = opRemove) and (FDataLink <> nil) and
  3231.     (AComponent = DataSource) then DataSource := nil;
  3232. end;
  3233.  
  3234. procedure TDBNavigator.SetVisible(Value: TButtonSet);
  3235. var
  3236.   I: TNavigateBtn;
  3237.   W, H: Integer;
  3238. begin
  3239.   W := Width;
  3240.   H := Height;
  3241.   FVisibleButtons := Value;
  3242.   for I := Low(Buttons) to High(Buttons) do
  3243.     Buttons[I].Visible := I in FVisibleButtons;
  3244.   AdjustSize (W, H);
  3245.   if (W <> Width) or (H <> Height) then
  3246.     inherited SetBounds (Left, Top, W, H);
  3247.   Invalidate;
  3248. end;
  3249.  
  3250. procedure TDBNavigator.AdjustSize (var W: Integer; var H: Integer);
  3251. var
  3252.   Count: Integer;
  3253.   MinW: Integer;
  3254.   I: TNavigateBtn;
  3255.   Space, Temp, Remain: Integer;
  3256.   X: Integer;
  3257. begin
  3258.   if (csLoading in ComponentState) then Exit;
  3259.   if Buttons[nbFirst] = nil then Exit;
  3260.  
  3261.   Count := 0;
  3262.   for I := Low(Buttons) to High(Buttons) do
  3263.   begin
  3264.     if Buttons[I].Visible then
  3265.     begin
  3266.       Inc(Count);
  3267.     end;
  3268.   end;
  3269.   if Count = 0 then Inc(Count);
  3270.  
  3271.   MinW := Count * MinBtnSize.X;
  3272.   if W < MinW then W := MinW;
  3273.   if H < MinBtnSize.Y then H := MinBtnSize.Y;
  3274.  
  3275.   ButtonWidth := W div Count;
  3276.   Temp := Count * ButtonWidth;
  3277.   if Align = alNone then W := Temp;
  3278.  
  3279.   X := 0;
  3280.   Remain := W - Temp;
  3281.   Temp := Count div 2;
  3282.   for I := Low(Buttons) to High(Buttons) do
  3283.   begin
  3284.     if Buttons[I].Visible then
  3285.     begin
  3286.       Space := 0;
  3287.       if Remain <> 0 then
  3288.       begin
  3289.         Dec(Temp, Remain);
  3290.         if Temp < 0 then
  3291.         begin
  3292.           Inc(Temp, Count);
  3293.           Space := 1;
  3294.         end;
  3295.       end;
  3296.       Buttons[I].SetBounds(X, 0, ButtonWidth + Space, Height);
  3297.       Inc(X, ButtonWidth + Space);
  3298.     end
  3299.     else
  3300.       Buttons[I].SetBounds (Width + 1, 0, ButtonWidth, Height);
  3301.   end;
  3302. end;
  3303.  
  3304. procedure TDBNavigator.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  3305. var
  3306.   W, H: Integer;
  3307. begin
  3308.   W := AWidth;
  3309.   H := AHeight;
  3310.   if not HandleAllocated then AdjustSize (W, H);
  3311.   inherited SetBounds (ALeft, ATop, W, H);
  3312. end;
  3313.  
  3314. procedure TDBNavigator.WMSize(var Message: TWMSize);
  3315. var
  3316.   W, H: Integer;
  3317. begin
  3318.   inherited;
  3319.   { check for minimum size }
  3320.   W := Width;
  3321.   H := Height;
  3322.   AdjustSize (W, H);
  3323.   if (W <> Width) or (H <> Height) then
  3324.     inherited SetBounds(Left, Top, W, H);
  3325.   Message.Result := 0;
  3326. end;
  3327.  
  3328. procedure TDBNavigator.ClickHandler(Sender: TObject);
  3329. begin
  3330.   BtnClick (TNavButton (Sender).Index);
  3331. end;
  3332.  
  3333. procedure TDBNavigator.BtnMouseDown(Sender: TObject; Button: TMouseButton;
  3334.   Shift: TShiftState; X, Y: Integer);
  3335. var
  3336.   OldFocus: TNavigateBtn;
  3337. begin
  3338.   OldFocus := FocusedButton;
  3339.   FocusedButton := TNavButton (Sender).Index;
  3340.   if TabStop and (GetFocus <> Handle) and CanFocus then
  3341.   begin
  3342.     SetFocus;
  3343.     if (GetFocus <> Handle) then
  3344.       Exit;
  3345.   end
  3346.   else if TabStop and (GetFocus = Handle) and (OldFocus <> FocusedButton) then
  3347.   begin
  3348.     Buttons[OldFocus].Invalidate;
  3349.     Buttons[FocusedButton].Invalidate;
  3350.   end;
  3351. end;
  3352.  
  3353. procedure TDBNavigator.BtnClick(Index: TNavigateBtn);
  3354. begin
  3355.   if (DataSource <> nil) and (DataSource.State <> dsInactive) then
  3356.   begin
  3357.     with DataSource.DataSet do
  3358.     begin
  3359.       case Index of
  3360.         nbPrior: Prior;
  3361.         nbNext: Next;
  3362.         nbFirst: First;
  3363.         nbLast: Last;
  3364.         nbInsert: Insert;
  3365.         nbEdit: Edit;
  3366.         nbCancel: Cancel;
  3367.         nbPost: Post;
  3368.         nbRefresh: Refresh;
  3369.         nbDelete:
  3370.           if not FConfirmDelete or
  3371.             (MessageDlg(SDeleteRecordQuestion, mtConfirmation,
  3372.             mbOKCancel, 0) <> idCancel) then Delete;
  3373.       end;
  3374.     end;
  3375.   end;
  3376.   if not (csDesigning in ComponentState) and Assigned(FOnNavClick) then
  3377.     FOnNavClick(Self, Index);
  3378. end;
  3379.  
  3380. procedure TDBNavigator.WMSetFocus(var Message: TWMSetFocus);
  3381. begin
  3382.   Buttons[FocusedButton].Invalidate;
  3383. end;
  3384.  
  3385. procedure TDBNavigator.WMKillFocus(var Message: TWMKillFocus);
  3386. begin
  3387.   Buttons[FocusedButton].Invalidate;
  3388. end;
  3389.  
  3390. procedure TDBNavigator.KeyDown(var Key: Word; Shift: TShiftState);
  3391. var
  3392.   NewFocus: TNavigateBtn;
  3393.   OldFocus: TNavigateBtn;
  3394. begin
  3395.   OldFocus := FocusedButton;
  3396.   case Key of
  3397.     VK_RIGHT:
  3398.       begin
  3399.         NewFocus := FocusedButton;
  3400.         repeat
  3401.           if NewFocus < High(Buttons) then
  3402.             NewFocus := Succ(NewFocus);
  3403.         until (NewFocus = High(Buttons)) or (Buttons[NewFocus].Visible);
  3404.         if NewFocus <> FocusedButton then
  3405.         begin
  3406.           FocusedButton := NewFocus;
  3407.           Buttons[OldFocus].Invalidate;
  3408.           Buttons[FocusedButton].Invalidate;
  3409.         end;
  3410.       end;
  3411.     VK_LEFT:
  3412.       begin
  3413.         NewFocus := FocusedButton;
  3414.         repeat
  3415.           if NewFocus > Low(Buttons) then
  3416.             NewFocus := Pred(NewFocus);
  3417.         until (NewFocus = Low(Buttons)) or (Buttons[NewFocus].Visible);
  3418.         if NewFocus <> FocusedButton then
  3419.         begin
  3420.           FocusedButton := NewFocus;
  3421.           Buttons[OldFocus].Invalidate;
  3422.           Buttons[FocusedButton].Invalidate;
  3423.         end;
  3424.       end;
  3425.     VK_SPACE:
  3426.       begin
  3427.         if Buttons[FocusedButton].Enabled then
  3428.           Buttons[FocusedButton].Click;
  3429.       end;
  3430.   end;
  3431. end;
  3432.  
  3433. procedure TDBNavigator.WMGetDlgCode(var Message: TWMGetDlgCode);
  3434. begin
  3435.   Message.Result := DLGC_WANTARROWS;
  3436. end;
  3437.  
  3438. procedure TDBNavigator.DataChanged;
  3439. var
  3440.   UpEnable, DnEnable: Boolean;
  3441. begin
  3442.   UpEnable := Enabled and FDataLink.Active and not FDataLink.DataSet.BOF;
  3443.   DnEnable := Enabled and FDataLink.Active and not FDataLink.DataSet.EOF;
  3444.   Buttons[nbFirst].Enabled := UpEnable;
  3445.   Buttons[nbPrior].Enabled := UpEnable;
  3446.   Buttons[nbNext].Enabled := DnEnable;
  3447.   Buttons[nbLast].Enabled := DnEnable;
  3448.   Buttons[nbDelete].Enabled := Enabled and FDataLink.Active and
  3449.     FDataLink.DataSet.CanModify and
  3450.     not (FDataLink.DataSet.BOF and FDataLink.DataSet.EOF);
  3451. end;
  3452.  
  3453. procedure TDBNavigator.EditingChanged;
  3454. var
  3455.   CanModify: Boolean;
  3456. begin
  3457.   CanModify := Enabled and FDataLink.Active and FDataLink.DataSet.CanModify;
  3458.   Buttons[nbInsert].Enabled := CanModify;
  3459.   Buttons[nbEdit].Enabled := CanModify and not FDataLink.Editing;
  3460.   Buttons[nbPost].Enabled := CanModify and FDataLink.Editing;
  3461.   Buttons[nbCancel].Enabled := CanModify and FDataLink.Editing;
  3462.   Buttons[nbRefresh].Enabled := CanModify;
  3463. end;
  3464.  
  3465. procedure TDBNavigator.ActiveChanged;
  3466. var
  3467.   I: TNavigateBtn;
  3468. begin
  3469.   if not (Enabled and FDataLink.Active) then
  3470.     for I := Low(Buttons) to High(Buttons) do
  3471.       Buttons[I].Enabled := False
  3472.   else
  3473.   begin
  3474.     DataChanged;
  3475.     EditingChanged;
  3476.   end;
  3477. end;
  3478.  
  3479. procedure TDBNavigator.CMEnabledChanged(var Message: TMessage);
  3480. begin
  3481.   inherited;
  3482.   if not (csLoading in ComponentState) then
  3483.     ActiveChanged;
  3484. end;
  3485.  
  3486. procedure TDBNavigator.SetDataSource(Value: TDataSource);
  3487. begin
  3488.   FDataLink.DataSource := Value;
  3489.   if not (csLoading in ComponentState) then
  3490.     ActiveChanged;
  3491.   if Value <> nil then Value.FreeNotification(Self);
  3492. end;
  3493.  
  3494. function TDBNavigator.GetDataSource: TDataSource;
  3495. begin
  3496.   Result := FDataLink.DataSource;
  3497. end;
  3498.  
  3499. procedure TDBNavigator.Loaded;
  3500. var
  3501.   W, H: Integer;
  3502. begin
  3503.   inherited Loaded;
  3504.   W := Width;
  3505.   H := Height;
  3506.   AdjustSize (W, H);
  3507.   if (W <> Width) or (H <> Height) then
  3508.     inherited SetBounds (Left, Top, W, H);
  3509.   InitHints;
  3510.   ActiveChanged;
  3511. end;
  3512.  
  3513. {TNavButton}
  3514.  
  3515. destructor TNavButton.Destroy;
  3516. begin
  3517.   if FRepeatTimer <> nil then
  3518.     FRepeatTimer.Free;
  3519.   inherited Destroy;
  3520. end;
  3521.  
  3522. procedure TNavButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  3523.   X, Y: Integer);
  3524. begin
  3525.   inherited MouseDown (Button, Shift, X, Y);
  3526.   if nsAllowTimer in FNavStyle then
  3527.   begin
  3528.     if FRepeatTimer = nil then
  3529.       FRepeatTimer := TTimer.Create(Self);
  3530.  
  3531.     FRepeatTimer.OnTimer := TimerExpired;
  3532.     FRepeatTimer.Interval := InitRepeatPause;
  3533.     FRepeatTimer.Enabled  := True;
  3534.   end;
  3535. end;
  3536.  
  3537. procedure TNavButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  3538.                                   X, Y: Integer);
  3539. begin
  3540.   inherited MouseUp (Button, Shift, X, Y);
  3541.   if FRepeatTimer <> nil then
  3542.     FRepeatTimer.Enabled  := False;
  3543. end;
  3544.  
  3545. procedure TNavButton.TimerExpired(Sender: TObject);
  3546. begin
  3547.   FRepeatTimer.Interval := RepeatPause;
  3548.   if (FState = bsDown) and MouseCapture then
  3549.   begin
  3550.     try
  3551.       Click;
  3552.     except
  3553.       FRepeatTimer.Enabled := False;
  3554.       raise;
  3555.     end;
  3556.   end;
  3557. end;
  3558.  
  3559. procedure TNavButton.Paint;
  3560. var
  3561.   R: TRect;
  3562. begin
  3563.   inherited Paint;
  3564.   if (GetFocus = Parent.Handle) and
  3565.      (FIndex = TDBNavigator (Parent).FocusedButton) then
  3566.   begin
  3567.     R := Bounds(0, 0, Width, Height);
  3568.     InflateRect(R, -3, -3);
  3569.     if FState = bsDown then
  3570.       OffsetRect(R, 1, 1);
  3571.     DrawFocusRect(Canvas.Handle, R);
  3572.   end;
  3573. end;
  3574.  
  3575. { TNavDataLink }
  3576.  
  3577. constructor TNavDataLink.Create(ANav: TDBNavigator);
  3578. begin
  3579.   inherited Create;
  3580.   FNavigator := ANav;
  3581. end;
  3582.  
  3583. destructor TNavDataLink.Destroy;
  3584. begin
  3585.   FNavigator := nil;
  3586.   inherited Destroy;
  3587. end;
  3588.  
  3589. procedure TNavDataLink.EditingChanged;
  3590. begin
  3591.   if FNavigator <> nil then FNavigator.EditingChanged;
  3592. end;
  3593.  
  3594. procedure TNavDataLink.DataSetChanged;
  3595. begin
  3596.   if FNavigator <> nil then FNavigator.DataChanged;
  3597. end;
  3598.  
  3599. procedure TNavDataLink.ActiveChanged;
  3600. begin
  3601.   if FNavigator <> nil then FNavigator.ActiveChanged;
  3602. end;
  3603.  
  3604. { TDataSourceLink }
  3605.  
  3606. procedure TDataSourceLink.ActiveChanged;
  3607. begin
  3608.   if FDBLookupControl <> nil then FDBLookupControl.DataLinkActiveChanged;
  3609. end;
  3610.  
  3611. procedure TDataSourceLink.RecordChanged(Field: TField);
  3612. begin
  3613.   if FDBLookupControl <> nil then FDBLookupControl.DataLinkRecordChanged(Field);
  3614. end;
  3615.  
  3616. procedure TDataSourceLink.FocusControl(Field: TFieldRef);
  3617. begin
  3618.   if (Field^ <> nil) and (Field^ = FDBLookupControl.Field) and
  3619.     (FDBLookupControl <> nil) and FDBLookupControl.CanFocus then
  3620.   begin
  3621.     Field^ := nil;
  3622.     FDBLookupControl.SetFocus;
  3623.   end;
  3624. end;
  3625.  
  3626. { TListSourceLink }
  3627.  
  3628. procedure TListSourceLink.ActiveChanged;
  3629. begin
  3630.   if FDBLookupControl <> nil then FDBLookupControl.ListLinkActiveChanged;
  3631. end;
  3632.  
  3633. procedure TListSourceLink.DataSetChanged;
  3634. begin
  3635.   if FDBLookupControl <> nil then FDBLookupControl.ListLinkDataChanged;
  3636. end;
  3637.  
  3638. { TDBLookupControl }
  3639.  
  3640. function VarEquals(const V1, V2: Variant): Boolean;
  3641. begin
  3642.   Result := False;
  3643.   try
  3644.     Result := V1 = V2;
  3645.   except
  3646.   end;
  3647. end;
  3648.  
  3649. var
  3650.   SearchTickCount: Integer = 0;
  3651.  
  3652. constructor TDBLookupControl.Create(AOwner: TComponent);
  3653. begin
  3654.   inherited Create(AOwner);
  3655.   if NewStyleControls then
  3656.     ControlStyle := [csOpaque] else
  3657.     ControlStyle := [csOpaque, csFramed];
  3658.   ParentColor := False;
  3659.   TabStop := True;
  3660.   FLookupSource := TDataSource.Create(Self);
  3661.   FDataLink := TDataSourceLink.Create;
  3662.   FDataLink.FDBLookupControl := Self;
  3663.   FListLink := TListSourceLink.Create;
  3664.   FListLink.FDBLookupControl := Self;
  3665.   FListFields := TList.Create;
  3666.   FKeyValue := Null;
  3667. end;
  3668.  
  3669. destructor TDBLookupControl.Destroy;
  3670. begin
  3671.   FListFields.Free;
  3672.   FListLink.FDBLookupControl := nil;
  3673.   FListLink.Free;
  3674.   FDataLink.FDBLookupControl := nil;
  3675.   FDataLink.Free;
  3676.   inherited Destroy;
  3677. end;
  3678.  
  3679. function TDBLookupControl.CanModify: Boolean;
  3680. begin
  3681.   Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or
  3682.     (FMasterField <> nil) and FMasterField.CanModify);
  3683. end;
  3684.  
  3685. procedure TDBLookupControl.CheckNotCircular;
  3686. begin
  3687.   if FDataLink.Active and FDataLink.DataSet.IsLinkedTo(ListSource) then
  3688.     DatabaseError(SCircularDataLink);
  3689. end;
  3690.  
  3691. procedure TDBLookupControl.CheckNotLookup;
  3692. begin
  3693.   if FLookupMode then DatabaseError(SPropDefByLookup);
  3694.   if FDataLink.DataSourceFixed then DatabaseError(SDataSourceFixed);
  3695. end;
  3696.  
  3697. procedure TDBLookupControl.DataLinkActiveChanged;
  3698. begin
  3699.   FDataField := nil;
  3700.   FMasterField := nil;
  3701.   if FDataLink.Active and (FDataFieldName <> '') then
  3702.   begin
  3703.     CheckNotCircular;
  3704.     FDataField := GetFieldProperty(FDataLink.DataSet, Self, FDataFieldName);
  3705.     FMasterField := FDataField;
  3706.   end;
  3707.   SetLookupMode((FDataField <> nil) and (FDataField.FieldKind = fkLookup));
  3708.   DataLinkRecordChanged(nil);
  3709. end;
  3710.  
  3711. procedure TDBLookupControl.DataLinkRecordChanged(Field: TField);
  3712. begin
  3713.   if (Field = nil) or (Field = FMasterField) then
  3714.     if FMasterField <> nil then
  3715.       SetKeyValue(FMasterField.Value) else
  3716.       SetKeyValue(Null);
  3717. end;
  3718.  
  3719. function TDBLookupControl.GetBorderSize: Integer;
  3720. var
  3721.   Params: TCreateParams;
  3722.   R: TRect;
  3723. begin
  3724.   CreateParams(Params);
  3725.   SetRect(R, 0, 0, 0, 0);
  3726.   AdjustWindowRectEx(R, Params.Style, False, Params.ExStyle);
  3727.   Result := R.Bottom - R.Top;
  3728. end;
  3729.  
  3730. function TDBLookupControl.GetDataSource: TDataSource;
  3731. begin
  3732.   Result := FDataLink.DataSource;
  3733. end;
  3734.  
  3735. function TDBLookupControl.GetKeyFieldName: string;
  3736. begin
  3737.   if FLookupMode then Result := '' else Result := FKeyFieldName;
  3738. end;
  3739.  
  3740. function TDBLookupControl.GetListSource: TDataSource;
  3741. begin
  3742.   if FLookupMode then Result := nil else Result := FListLink.DataSource;
  3743. end;
  3744.  
  3745. function TDBLookupControl.GetReadOnly: Boolean;
  3746. begin
  3747.   Result := FDataLink.ReadOnly;
  3748. end;
  3749.  
  3750. function TDBLookupControl.GetTextHeight: Integer;
  3751. var
  3752.   DC: HDC;
  3753.   SaveFont: HFont;
  3754.   Metrics: TTextMetric;
  3755. begin
  3756.   DC := GetDC(0);
  3757.   SaveFont := SelectObject(DC, Font.Handle);
  3758.   GetTextMetrics(DC, Metrics);
  3759.   SelectObject(DC, SaveFont);
  3760.   ReleaseDC(0, DC);
  3761.   Result := Metrics.tmHeight;
  3762. end;
  3763.  
  3764. procedure TDBLookupControl.KeyValueChanged;
  3765. begin
  3766. end;
  3767.  
  3768. procedure TDBLookupControl.ListLinkActiveChanged;
  3769. var
  3770.   DataSet: TDataSet;
  3771.   ResultField: TField;
  3772. begin
  3773.   FListActive := False;
  3774.   FKeyField := nil;
  3775.   FListField := nil;
  3776.   FListFields.Clear;
  3777.   if FListLink.Active and (FKeyFieldName <> '') then
  3778.   begin
  3779.     CheckNotCircular;
  3780.     DataSet := FListLink.DataSet;
  3781.     FKeyField := GetFieldProperty(DataSet, Self, FKeyFieldName);
  3782.     try
  3783.       DataSet.GetFieldList(FListFields, FListFieldName);
  3784.     except
  3785.       DatabaseErrorFmt(SFieldNotFound, [Self.Name, FListFieldName]);
  3786.     end;
  3787.     if FLookupMode then
  3788.     begin
  3789.       ResultField := GetFieldProperty(DataSet, Self, FDataField.LookupResultField);
  3790.       if FListFields.IndexOf(ResultField) < 0 then
  3791.         FListFields.Insert(0, ResultField);
  3792.       FListField := ResultField;
  3793.     end else
  3794.     begin
  3795.       if FListFields.Count = 0 then FListFields.Add(FKeyField);
  3796.       if (FListFieldIndex >= 0) and (FListFieldIndex < FListFields.Count) then
  3797.         FListField := FListFields[FListFieldIndex] else
  3798.         FListField := FListFields[0];
  3799.     end;
  3800.     FListActive := True;
  3801.   end;
  3802. end;
  3803.  
  3804. procedure TDBLookupControl.ListLinkDataChanged;
  3805. begin
  3806. end;
  3807.  
  3808. function TDBLookupControl.LocateKey: Boolean;
  3809. begin
  3810.   Result := False;
  3811.   try
  3812.     if not VarIsNull(FKeyValue) and
  3813.       FListLink.DataSet.Locate(FKeyFieldName, FKeyValue, []) then
  3814.       Result := True;
  3815.   except
  3816.   end;
  3817. end;
  3818.  
  3819. procedure TDBLookupControl.Notification(AComponent: TComponent;
  3820.   Operation: TOperation);
  3821. begin
  3822.   inherited Notification(AComponent, Operation);
  3823.   if Operation = opRemove then
  3824.   begin
  3825.     if (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil;
  3826.     if (FListLink <> nil) and (AComponent = ListSource) then ListSource := nil;
  3827.   end;
  3828. end;
  3829.  
  3830. procedure TDBLookupControl.ProcessSearchKey(Key: Char);
  3831. var
  3832.   TickCount: Integer;
  3833.   S: string;
  3834. begin
  3835.   if (FListField <> nil) and (FListField.FieldKind = fkData) and
  3836.     (FListField.DataType = ftString) then
  3837.     case Key of
  3838.       #8, #27: FSearchText := '';
  3839.       #32..#255:
  3840.         if CanModify then
  3841.         begin
  3842.           TickCount := GetTickCount;
  3843.           if TickCount - SearchTickCount > 2000 then FSearchText := '';
  3844.           SearchTickCount := TickCount;
  3845.           if Length(FSearchText) < 32 then
  3846.           begin
  3847.             S := FSearchText + Key;
  3848.             if FListLink.DataSet.Locate(FListField.FieldName, S,
  3849.               [loCaseInsensitive, loPartialKey]) then
  3850.             begin
  3851.               SelectKeyValue(FKeyField.Value);
  3852.               FSearchText := S;
  3853.             end;
  3854.           end;
  3855.         end;
  3856.     end;
  3857. end;
  3858.  
  3859. procedure TDBLookupControl.SelectKeyValue(const Value: Variant);
  3860. begin
  3861.   if FMasterField <> nil then
  3862.   begin
  3863.     if FDataLink.Edit then
  3864.       FMasterField.Value := Value;
  3865.   end else
  3866.     SetKeyValue(Value);
  3867.   Repaint;
  3868.   Click;
  3869. end;
  3870.  
  3871. procedure TDBLookupControl.SetDataFieldName(const Value: string);
  3872. begin
  3873.   if FDataFieldName <> Value then
  3874.   begin
  3875.     FDataFieldName := Value;
  3876.     DataLinkActiveChanged;
  3877.   end;
  3878. end;
  3879.  
  3880. procedure TDBLookupControl.SetDataSource(Value: TDataSource);
  3881. begin
  3882.   FDataLink.DataSource := Value;
  3883.   if Value <> nil then Value.FreeNotification(Self);
  3884. end;
  3885.  
  3886. procedure TDBLookupControl.SetKeyFieldName(const Value: string);
  3887. begin
  3888.   CheckNotLookup;
  3889.   if FKeyFieldName <> Value then
  3890.   begin
  3891.     FKeyFieldName := Value;
  3892.     ListLinkActiveChanged;
  3893.   end;
  3894. end;
  3895.  
  3896. procedure TDBLookupControl.SetKeyValue(const Value: Variant);
  3897. begin
  3898.   if not VarEquals(FKeyValue, Value) then
  3899.   begin
  3900.     FKeyValue := Value;
  3901.     KeyValueChanged;
  3902.   end;
  3903. end;
  3904.  
  3905. procedure TDBLookupControl.SetListFieldName(const Value: string);
  3906. begin
  3907.   if FListFieldName <> Value then
  3908.   begin
  3909.     FListFieldName := Value;
  3910.     ListLinkActiveChanged;
  3911.   end;
  3912. end;
  3913.  
  3914. procedure TDBLookupControl.SetListSource(Value: TDataSource);
  3915. begin
  3916.   CheckNotLookup;
  3917.   FListLink.DataSource := Value;
  3918.   if Value <> nil then Value.FreeNotification(Self);
  3919. end;
  3920.  
  3921. procedure TDBLookupControl.SetLookupMode(Value: Boolean);
  3922. begin
  3923.   if FLookupMode <> Value then
  3924.     if Value then
  3925.     begin
  3926.       FMasterField := GetFieldProperty(FDataField.DataSet, Self, FDataField.KeyFields);
  3927.       FLookupSource.DataSet := FDataField.LookupDataSet;
  3928.       FKeyFieldName := FDataField.LookupKeyFields;
  3929.       FLookupMode := True;
  3930.       FListLink.DataSource := FLookupSource;
  3931.     end else
  3932.     begin
  3933.       FListLink.DataSource := nil;
  3934.       FLookupMode := False;
  3935.       FKeyFieldName := '';
  3936.       FLookupSource.DataSet := nil;
  3937.       FMasterField := FDataField;
  3938.     end;
  3939. end;
  3940.  
  3941. procedure TDBLookupControl.SetReadOnly(Value: Boolean);
  3942. begin
  3943.   FDataLink.ReadOnly := Value;
  3944. end;
  3945.  
  3946. procedure TDBLookupControl.WMGetDlgCode(var Message: TMessage);
  3947. begin
  3948.   Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
  3949. end;
  3950.  
  3951. procedure TDBLookupControl.WMKillFocus(var Message: TMessage);
  3952. begin
  3953.   FFocused := False;
  3954.   Invalidate;
  3955. end;
  3956.  
  3957. procedure TDBLookupControl.WMSetFocus(var Message: TMessage);
  3958. begin
  3959.   FFocused := True;
  3960.   Invalidate;
  3961. end;
  3962.  
  3963. { TDBLookupListBox }
  3964.  
  3965. constructor TDBLookupListBox.Create(AOwner: TComponent);
  3966. begin
  3967.   inherited Create(AOwner);
  3968.   ControlStyle := ControlStyle + [csDoubleClicks];
  3969.   Width := 121;
  3970.   FBorderStyle := bsSingle;
  3971.   RowCount := 7;
  3972. end;
  3973.  
  3974. procedure TDBLookupListBox.CreateParams(var Params: TCreateParams);
  3975. begin
  3976.   inherited CreateParams(Params);
  3977.   with Params do
  3978.     if FBorderStyle = bsSingle then
  3979.       if NewStyleControls and Ctl3D then
  3980.         ExStyle := ExStyle or WS_EX_CLIENTEDGE
  3981.       else
  3982.         Style := Style or WS_BORDER;
  3983. end;
  3984.  
  3985. procedure TDBLookupListBox.CreateWnd;
  3986. begin
  3987.   inherited CreateWnd;
  3988.   UpdateScrollBar;
  3989. end;
  3990.  
  3991. function TDBLookupListBox.GetKeyIndex: Integer;
  3992. var
  3993.   FieldValue: Variant;
  3994. begin
  3995.   if not VarIsNull(FKeyValue) then
  3996.     for Result := 0 to FRecordCount - 1 do
  3997.     begin
  3998.       FListLink.ActiveRecord := Result;
  3999.       FieldValue := FKeyField.Value;
  4000.       FListLink.ActiveRecord := FRecordIndex;
  4001.       if VarEquals(FieldValue, FKeyValue) then Exit;
  4002.     end;
  4003.   Result := -1;
  4004. end;
  4005.  
  4006. procedure TDBLookupListBox.KeyDown(var Key: Word; Shift: TShiftState);
  4007. var
  4008.   Delta, KeyIndex: Integer;
  4009. begin
  4010.   inherited KeyDown(Key, Shift);
  4011.   if CanModify then
  4012.   begin
  4013.     Delta := 0;
  4014.     case Key of
  4015.       VK_UP, VK_LEFT: Delta := -1;
  4016.       VK_DOWN, VK_RIGHT: Delta := 1;
  4017.       VK_PRIOR: Delta := 1 - FRowCount;
  4018.       VK_NEXT: Delta := FRowCount - 1;
  4019.       VK_HOME: Delta := -Maxint;
  4020.       VK_END: Delta := Maxint;
  4021.     end;
  4022.     if Delta <> 0 then
  4023.     begin
  4024.       FSearchText := '';
  4025.       if Delta = -Maxint then FListLink.DataSet.First else
  4026.         if Delta = Maxint then FListLink.DataSet.Last else
  4027.         begin
  4028.           KeyIndex := GetKeyIndex;
  4029.           if KeyIndex >= 0 then
  4030.             FListLink.DataSet.MoveBy(KeyIndex - FRecordIndex)
  4031.           else
  4032.           begin
  4033.             KeyValueChanged;
  4034.             Delta := 0;
  4035.           end;
  4036.           FListLink.DataSet.MoveBy(Delta);
  4037.         end;
  4038.       SelectCurrent;
  4039.     end;
  4040.   end;
  4041. end;
  4042.  
  4043. procedure TDBLookupListBox.KeyPress(var Key: Char);
  4044. begin
  4045.   inherited KeyPress(Key);
  4046.   ProcessSearchKey(Key);
  4047. end;
  4048.  
  4049. procedure TDBLookupListBox.KeyValueChanged;
  4050. begin
  4051.   if FListActive and not FLockPosition then
  4052.     if not LocateKey then FListLink.DataSet.First;
  4053.   if FListField <> nil then
  4054.     FSelectedItem := FListField.DisplayText else
  4055.     FSelectedItem := '';
  4056. end;
  4057.  
  4058. procedure TDBLookupListBox.ListLinkActiveChanged;
  4059. begin
  4060.   try
  4061.     inherited;
  4062.   finally
  4063.     if FListActive then KeyValueChanged else ListLinkDataChanged;
  4064.   end;
  4065. end;
  4066.  
  4067. procedure TDBLookupListBox.ListLinkDataChanged;
  4068. begin
  4069.   if FListActive then
  4070.   begin
  4071.     FRecordIndex := FListLink.ActiveRecord;
  4072.     FRecordCount := FListLink.RecordCount;
  4073.     FKeySelected := not VarIsNull(FKeyValue) or
  4074.       not FListLink.DataSet.BOF;
  4075.   end else
  4076.   begin
  4077.     FRecordIndex := 0;
  4078.     FRecordCount := 0;
  4079.     FKeySelected := False;
  4080.   end;
  4081.   if HandleAllocated then
  4082.   begin
  4083.     UpdateScrollBar;
  4084.     Invalidate;
  4085.   end;
  4086. end;
  4087.  
  4088. procedure TDBLookupListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  4089.   X, Y: Integer);
  4090. begin
  4091.   if Button = mbLeft then
  4092.   begin
  4093.     FSearchText := '';
  4094.     if not FPopup then
  4095.     begin
  4096.       SetFocus;
  4097.       if not FFocused then Exit;
  4098.     end;
  4099.     if CanModify then
  4100.       if ssDouble in Shift then
  4101.       begin
  4102.         if FRecordIndex = Y div GetTextHeight then DblClick;
  4103.       end else
  4104.       begin
  4105.         MouseCapture := True;
  4106.         FTracking := True;
  4107.         SelectItemAt(X, Y);
  4108.       end;
  4109.   end;
  4110.   inherited MouseDown(Button, Shift, X, Y);
  4111. end;
  4112.  
  4113. procedure TDBLookupListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  4114. begin
  4115.   if FTracking then
  4116.   begin
  4117.     SelectItemAt(X, Y);
  4118.     FMousePos := Y;
  4119.     TimerScroll;
  4120.   end;
  4121.   inherited MouseMove(Shift, X, Y);
  4122. end;
  4123.  
  4124. procedure TDBLookupListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  4125.   X, Y: Integer);
  4126. begin
  4127.   if FTracking then
  4128.   begin
  4129.     StopTracking;
  4130.     SelectItemAt(X, Y);
  4131.   end;
  4132.   inherited MouseUp(Button, Shift, X, Y);
  4133. end;
  4134.  
  4135. procedure TDBLookupListBox.Paint;
  4136. var
  4137.   I, J, W, X, TextWidth, TextHeight, LastFieldIndex: Integer;
  4138.   S: string;
  4139.   R: TRect;
  4140.   Selected: Boolean;
  4141.   Field: TField;
  4142. begin
  4143.   Canvas.Font := Font;
  4144.   TextWidth := Canvas.TextWidth('0');
  4145.   TextHeight := Canvas.TextHeight('0');
  4146.   LastFieldIndex := FListFields.Count - 1;
  4147.   if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then
  4148.     Canvas.Pen.Color := clBtnFace else
  4149.     Canvas.Pen.Color := clBtnShadow;
  4150.   for I := 0 to FRowCount - 1 do
  4151.   begin
  4152.     Canvas.Font.Color := Font.Color;
  4153.     Canvas.Brush.Color := Color;
  4154.     Selected := not FKeySelected and (I = 0);
  4155.     R.Top := I * TextHeight;
  4156.     R.Bottom := R.Top + TextHeight;
  4157.     if I < FRecordCount then
  4158.     begin
  4159.       FListLink.ActiveRecord := I;
  4160.       if not VarIsNull(FKeyValue) and
  4161.         VarEquals(FKeyField.Value, FKeyValue) then
  4162.       begin
  4163.         Canvas.Font.Color := clHighlightText;
  4164.         Canvas.Brush.Color := clHighlight;
  4165.         Selected := True;
  4166.       end;
  4167.       R.Right := 0;
  4168.       for J := 0 to LastFieldIndex do
  4169.       begin
  4170.         Field := FListFields[J];
  4171.         if J < LastFieldIndex then
  4172.           W := Field.DisplayWidth * TextWidth + 4 else
  4173.           W := ClientWidth - R.Right;
  4174.         S := Field.DisplayText;
  4175.         X := 2;
  4176.         case Field.Alignment of
  4177.           taRightJustify: X := W - Canvas.TextWidth(S) - 3;
  4178.           taCenter: X := (W - Canvas.TextWidth(S)) div 2;
  4179.         end;
  4180.         R.Left := R.Right;
  4181.         R.Right := R.Right + W;
  4182.         Canvas.TextRect(R, R.Left + X, R.Top, S);
  4183.         if J < LastFieldIndex then
  4184.         begin
  4185.           Canvas.MoveTo(R.Right, R.Top);
  4186.           Canvas.LineTo(R.Right, R.Bottom);
  4187.           Inc(R.Right);
  4188.           if R.Right >= ClientWidth then Break;
  4189.         end;
  4190.       end;
  4191.     end;
  4192.     R.Left := 0;
  4193.     R.Right := ClientWidth;
  4194.     if I >= FRecordCount then Canvas.FillRect(R);
  4195.     if Selected and (FFocused or FPopup) then Canvas.DrawFocusRect(R);
  4196.   end;
  4197.   if FRecordCount <> 0 then FListLink.ActiveRecord := FRecordIndex;
  4198. end;
  4199.  
  4200. procedure TDBLookupListBox.SelectCurrent;
  4201. begin
  4202.   FLockPosition := True;
  4203.   try
  4204.     SelectKeyValue(FKeyField.Value);
  4205.   finally
  4206.     FLockPosition := False;
  4207.   end;
  4208. end;
  4209.  
  4210. procedure TDBLookupListBox.SelectItemAt(X, Y: Integer);
  4211. var
  4212.   Delta: Integer;
  4213. begin
  4214.   if Y < 0 then Y := 0;
  4215.   if Y >= ClientHeight then Y := ClientHeight - 1;
  4216.   Delta := Y div GetTextHeight - FRecordIndex;
  4217.   FListLink.DataSet.MoveBy(Delta);
  4218.   SelectCurrent;
  4219. end;
  4220.  
  4221. procedure TDBLookupListBox.SetBorderStyle(Value: TBorderStyle);
  4222. begin
  4223.   if FBorderStyle <> Value then
  4224.   begin
  4225.     FBorderStyle := Value;
  4226.     RecreateWnd;
  4227.     RowCount := RowCount;
  4228.   end;
  4229. end;
  4230.  
  4231. procedure TDBLookupListBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  4232. var
  4233.   BorderSize, TextHeight, Rows: Integer;
  4234. begin
  4235.   BorderSize := GetBorderSize;
  4236.   TextHeight := GetTextHeight;
  4237.   Rows := (AHeight - BorderSize) div TextHeight;
  4238.   if Rows < 1 then Rows := 1;
  4239.   FRowCount := Rows;
  4240.   if FListLink.BufferCount <> Rows then
  4241.   begin
  4242.     FListLink.BufferCount := Rows;
  4243.     ListLinkDataChanged;
  4244.   end;
  4245.   inherited SetBounds(ALeft, ATop, AWidth, Rows * TextHeight + BorderSize);
  4246. end;
  4247.  
  4248. procedure TDBLookupListBox.SetRowCount(Value: Integer);
  4249. begin
  4250.   if Value < 1 then Value := 1;
  4251.   if Value > 100 then Value := 100;
  4252.   Height := Value * GetTextHeight + GetBorderSize;
  4253. end;
  4254.  
  4255. procedure TDBLookupListBox.StopTimer;
  4256. begin
  4257.   if FTimerActive then
  4258.   begin
  4259.     KillTimer(Handle, 1);
  4260.     FTimerActive := False;
  4261.   end;
  4262. end;
  4263.  
  4264. procedure TDBLookupListBox.StopTracking;
  4265. begin
  4266.   if FTracking then
  4267.   begin
  4268.     StopTimer;
  4269.     FTracking := False;
  4270.     MouseCapture := False;
  4271.   end;
  4272. end;
  4273.  
  4274. procedure TDBLookupListBox.TimerScroll;
  4275. var
  4276.   Delta, Distance, Interval: Integer;
  4277. begin
  4278.   Delta := 0;
  4279.   Distance := 0;
  4280.   if FMousePos < 0 then
  4281.   begin
  4282.     Delta := -1;
  4283.     Distance := -FMousePos;
  4284.   end;
  4285.   if FMousePos >= ClientHeight then
  4286.   begin
  4287.     Delta := 1;
  4288.     Distance := FMousePos - ClientHeight + 1;
  4289.   end;
  4290.   if Delta = 0 then StopTimer else
  4291.   begin
  4292.     if FListLink.DataSet.MoveBy(Delta) <> 0 then SelectCurrent;
  4293.     Interval := 200 - Distance * 15;
  4294.     if Interval < 0 then Interval := 0;
  4295.     SetTimer(Handle, 1, Interval, nil);
  4296.     FTimerActive := True;
  4297.   end;
  4298. end;
  4299.  
  4300. procedure TDBLookupListBox.UpdateScrollBar;
  4301. var
  4302.   Pos, Max: Integer;
  4303.   ScrollInfo: TScrollInfo;
  4304. begin
  4305.   Pos := 0;
  4306.   Max := 0;
  4307.   if FRecordCount = FRowCount then
  4308.   begin
  4309.     Max := 4;
  4310.     if not FListLink.DataSet.BOF then
  4311.       if not FListLink.DataSet.EOF then Pos := 2 else Pos := 4;
  4312.   end;
  4313.   ScrollInfo.cbSize := SizeOf(TScrollInfo);
  4314.   ScrollInfo.fMask := SIF_POS or SIF_RANGE;
  4315.   if not GetScrollInfo(Handle, SB_VERT, ScrollInfo) or
  4316.     (ScrollInfo.nPos <> Pos) or (ScrollInfo.nMax <> Max) then
  4317.   begin
  4318.     ScrollInfo.nMin := 0;
  4319.     ScrollInfo.nMax := Max;
  4320.     ScrollInfo.nPos := Pos;
  4321.     SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
  4322.   end;
  4323. end;
  4324.  
  4325. procedure TDBLookupListBox.CMCtl3DChanged(var Message: TMessage);
  4326. begin
  4327.   if NewStyleControls and (FBorderStyle = bsSingle) then
  4328.   begin
  4329.     RecreateWnd;
  4330.     RowCount := RowCount;
  4331.   end;
  4332.   inherited;
  4333. end;
  4334.  
  4335. procedure TDBLookupListBox.CMFontChanged(var Message: TMessage);
  4336. begin
  4337.   inherited;
  4338.   Height := Height;
  4339. end;
  4340.  
  4341. procedure TDBLookupListBox.WMCancelMode(var Message: TMessage);
  4342. begin
  4343.   StopTracking;
  4344.   inherited;
  4345. end;
  4346.  
  4347. procedure TDBLookupListBox.WMTimer(var Message: TMessage);
  4348. begin
  4349.   TimerScroll;
  4350. end;
  4351.  
  4352. procedure TDBLookupListBox.WMVScroll(var Message: TWMVScroll);
  4353. begin
  4354.   FSearchText := '';
  4355.   with Message, FListLink.DataSet do
  4356.     case ScrollCode of
  4357.       SB_LINEUP: MoveBy(-FRecordIndex - 1);
  4358.       SB_LINEDOWN: MoveBy(FRecordCount - FRecordIndex);
  4359.       SB_PAGEUP: MoveBy(-FRecordIndex - FRecordCount + 1);
  4360.       SB_PAGEDOWN: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  4361.       SB_THUMBPOSITION:
  4362.         begin
  4363.           case Pos of
  4364.             0: First;
  4365.             1: MoveBy(-FRecordIndex - FRecordCount + 1);
  4366.             2: Exit;
  4367.             3: MoveBy(FRecordCount - FRecordIndex + FRecordCount - 2);
  4368.             4: Last;
  4369.           end;
  4370.         end;
  4371.       SB_BOTTOM: Last;
  4372.       SB_TOP: First;
  4373.     end;
  4374. end;
  4375.  
  4376. { TPopupDataList }
  4377.  
  4378. constructor TPopupDataList.Create(AOwner: TComponent);
  4379. begin
  4380.   inherited Create(AOwner);
  4381.   ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];
  4382.   FPopup := True;
  4383. end;
  4384.  
  4385. procedure TPopupDataList.CreateParams(var Params: TCreateParams);
  4386. begin
  4387.   inherited CreateParams(Params);
  4388.   with Params do
  4389.   begin
  4390.     Style := WS_POPUP or WS_BORDER;
  4391.     ExStyle := WS_EX_TOOLWINDOW;
  4392.     WindowClass.Style := CS_SAVEBITS;
  4393.   end;
  4394. end;
  4395.  
  4396. procedure TPopupDataList.WMMouseActivate(var Message: TMessage);
  4397. begin
  4398.   Message.Result := MA_NOACTIVATE;
  4399. end;
  4400.  
  4401. { TDBLookupComboBox }
  4402.  
  4403. constructor TDBLookupComboBox.Create(AOwner: TComponent);
  4404. begin
  4405.   inherited Create(AOwner);
  4406.   ControlStyle := ControlStyle + [csReplicatable];
  4407.   Width := 145;
  4408.   Height := 0;
  4409.   FDataList := TPopupDataList.Create(Self);
  4410.   FDataList.Visible := False;
  4411.   FDataList.Parent := Self;
  4412.   FDataList.OnMouseUp := ListMouseUp;
  4413.   FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
  4414.   FDropDownRows := 7;
  4415. end;
  4416.  
  4417. procedure TDBLookupComboBox.CloseUp(Accept: Boolean);
  4418. var
  4419.   ListValue: Variant;
  4420. begin
  4421.   if FListVisible then
  4422.   begin
  4423.     if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  4424.     ListValue := FDataList.KeyValue;
  4425.     SetWindowPos(FDataList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
  4426.       SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
  4427.     FListVisible := False;
  4428.     FDataList.ListSource := nil;
  4429.     Invalidate;
  4430.     FSearchText := '';
  4431.     if Accept and CanModify then SelectKeyValue(ListValue);
  4432.     if Assigned(FOnCloseUp) then FOnCloseUp(Self);
  4433.   end;
  4434. end;
  4435.  
  4436. procedure TDBLookupComboBox.CreateParams(var Params: TCreateParams);
  4437. begin
  4438.   inherited CreateParams(Params);
  4439.   with Params do
  4440.     if NewStyleControls and Ctl3D then
  4441.       ExStyle := ExStyle or WS_EX_CLIENTEDGE
  4442.     else
  4443.       Style := Style or WS_BORDER;
  4444. end;
  4445.  
  4446. procedure TDBLookupComboBox.DropDown;
  4447. var
  4448.   P: TPoint;
  4449.   I, Y: Integer;
  4450.   S: string;
  4451. begin
  4452.   if not FListVisible and FListActive then
  4453.   begin
  4454.     if Assigned(FOnDropDown) then FOnDropDown(Self);
  4455.     FDataList.Color := Color;
  4456.     FDataList.Font := Font;
  4457.     if FDropDownWidth > 0 then
  4458.       FDataList.Width := FDropDownWidth else
  4459.       FDataList.Width := Width;
  4460.     FDataList.ReadOnly := not CanModify;
  4461.     FDataList.RowCount := FDropDownRows;
  4462.     FDataList.KeyField := FKeyFieldName;
  4463.     for I := 0 to FListFields.Count - 1 do
  4464.       S := S + TField(FListFields[I]).FieldName + ';';
  4465.     FDataList.ListField := S;
  4466.     FDataList.ListFieldIndex := FListFields.IndexOf(FListField);
  4467.     FDataList.ListSource := FListLink.DataSource;
  4468.     FDataList.KeyValue := KeyValue;
  4469.     P := Parent.ClientToScreen(Point(Left, Top));
  4470.     Y := P.Y + Height;
  4471.     if Y + FDataList.Height > Screen.Height then Y := P.Y - FDataList.Height;
  4472.     case FDropDownAlign of
  4473.       daRight: Dec(P.X, FDataList.Width - Width);
  4474.       daCenter: Dec(P.X, (FDataList.Width - Width) div 2);
  4475.     end;
  4476.     SetWindowPos(FDataList.Handle, HWND_TOP, P.X, Y, 0, 0,
  4477.       SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
  4478.     FListVisible := True;
  4479.     Repaint;
  4480.   end;
  4481. end;
  4482.  
  4483. procedure TDBLookupComboBox.KeyDown(var Key: Word; Shift: TShiftState);
  4484. var
  4485.   Delta: Integer;
  4486. begin
  4487.   inherited KeyDown(Key, Shift);
  4488.   if FListActive and ((Key = VK_UP) or (Key = VK_DOWN)) then
  4489.     if ssAlt in Shift then
  4490.     begin
  4491.       if FListVisible then CloseUp(True) else DropDown;
  4492.       Key := 0;
  4493.     end else
  4494.       if not FListVisible then
  4495.       begin
  4496.         if not LocateKey then
  4497.           FListLink.DataSet.First
  4498.         else
  4499.         begin
  4500.           if Key = VK_UP then Delta := -1 else Delta := 1;
  4501.           FListLink.DataSet.MoveBy(Delta);
  4502.         end;
  4503.         SelectKeyValue(FKeyField.Value);
  4504.         Key := 0;
  4505.       end;
  4506.   if (Key <> 0) and FListVisible then FDataList.KeyDown(Key, Shift);
  4507. end;
  4508.  
  4509. procedure TDBLookupComboBox.KeyPress(var Key: Char);
  4510. begin
  4511.   inherited KeyPress(Key);
  4512.   if FListVisible then
  4513.     if Key in [#13, #27] then
  4514.       CloseUp(Key = #13)
  4515.     else
  4516.       FDataList.KeyPress(Key)
  4517.   else
  4518.     ProcessSearchKey(Key);
  4519. end;
  4520.  
  4521. procedure TDBLookupComboBox.KeyValueChanged;
  4522. begin
  4523.   if FLookupMode then
  4524.   begin
  4525.     FText := FDataField.DisplayText;
  4526.     FAlignment := FDataField.Alignment;
  4527.   end else
  4528.   if FListActive and LocateKey then
  4529.   begin
  4530.     FText := FListField.DisplayText;
  4531.     FAlignment := FListField.Alignment;
  4532.   end else
  4533.   begin
  4534.     FText := '';
  4535.     FAlignment := taLeftJustify;
  4536.   end;
  4537.   Invalidate;
  4538. end;
  4539.  
  4540. procedure TDBLookupComboBox.ListLinkActiveChanged;
  4541. begin
  4542.   inherited;
  4543.   KeyValueChanged;
  4544. end;
  4545.  
  4546. procedure TDBLookupComboBox.ListMouseUp(Sender: TObject; Button: TMouseButton;
  4547.   Shift: TShiftState; X, Y: Integer);
  4548. begin
  4549.   if Button = mbLeft then
  4550.     CloseUp(PtInRect(FDataList.ClientRect, Point(X, Y)));
  4551. end;
  4552.  
  4553. procedure TDBLookupComboBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  4554.   X, Y: Integer);
  4555. begin
  4556.   if Button = mbLeft then
  4557.   begin
  4558.     SetFocus;
  4559.     if not FFocused then Exit;
  4560.     if FListVisible then CloseUp(False) else
  4561.       if FListActive then
  4562.       begin
  4563.         MouseCapture := True;
  4564.         FTracking := True;
  4565.         TrackButton(X, Y);
  4566.         DropDown;
  4567.       end;
  4568.   end;
  4569.   inherited MouseDown(Button, Shift, X, Y);
  4570. end;
  4571.  
  4572. procedure TDBLookupComboBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  4573. var
  4574.   ListPos: TPoint;
  4575.   MousePos: TSmallPoint;
  4576. begin
  4577.   if FTracking then
  4578.   begin
  4579.     TrackButton(X, Y);
  4580.     if FListVisible then
  4581.     begin
  4582.       ListPos := FDataList.ScreenToClient(ClientToScreen(Point(X, Y)));
  4583.       if PtInRect(FDataList.ClientRect, ListPos) then
  4584.       begin
  4585.         StopTracking;
  4586.         MousePos := PointToSmallPoint(ListPos);
  4587.         SendMessage(FDataList.Handle, WM_LBUTTONDOWN, 0, Integer(MousePos));
  4588.         Exit;
  4589.       end;
  4590.     end;
  4591.   end;
  4592.   inherited MouseMove(Shift, X, Y);
  4593. end;
  4594.  
  4595. procedure TDBLookupComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  4596.   X, Y: Integer);
  4597. begin
  4598.   StopTracking;
  4599.   inherited MouseUp(Button, Shift, X, Y);
  4600. end;
  4601.  
  4602. procedure TDBLookupComboBox.Paint;
  4603. var
  4604.   W, X, Flags: Integer;
  4605.   Text: string;
  4606.   Alignment: TAlignment;
  4607.   Selected: Boolean;
  4608.   R: TRect;
  4609. begin
  4610.   Canvas.Font := Font;
  4611.   Canvas.Brush.Color := Color;
  4612.   Selected := FFocused and not FListVisible and
  4613.     not (csPaintCopy in ControlState);
  4614.   if Selected then
  4615.   begin
  4616.     Canvas.Font.Color := clHighlightText;
  4617.     Canvas.Brush.Color := clHighlight;
  4618.   end;
  4619.   if (csPaintCopy in ControlState) and (FDataField <> nil) then
  4620.   begin
  4621.     Text := FDataField.DisplayText;
  4622.     Alignment := FDataField.Alignment;
  4623.   end else
  4624.   begin
  4625.     Text := FText;
  4626.     Alignment := FAlignment;
  4627.   end;
  4628.   W := ClientWidth - FButtonWidth;
  4629.   X := 2;
  4630.   case Alignment of
  4631.     taRightJustify: X := W - Canvas.TextWidth(Text) - 3;
  4632.     taCenter: X := (W - Canvas.TextWidth(Text)) div 2;
  4633.   end;
  4634.   SetRect(R, 1, 1, W - 1, ClientHeight - 1);
  4635.   Canvas.TextRect(R, X, 2, Text);
  4636.   if Selected then Canvas.DrawFocusRect(R);
  4637.   SetRect(R, W, 0, ClientWidth, ClientHeight);
  4638.   if not FListActive then
  4639.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_INACTIVE
  4640.   else if FPressed then
  4641.     Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED
  4642.   else
  4643.     Flags := DFCS_SCROLLCOMBOBOX;
  4644.   DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);
  4645. end;
  4646.  
  4647. procedure TDBLookupComboBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  4648. begin
  4649.   inherited SetBounds(ALeft, ATop, AWidth, GetTextHeight + GetBorderSize + 4);
  4650. end;
  4651.  
  4652. procedure TDBLookupComboBox.StopTracking;
  4653. begin
  4654.   if FTracking then
  4655.   begin
  4656.     TrackButton(-1, -1);
  4657.     FTracking := False;
  4658.     MouseCapture := False;
  4659.   end;
  4660. end;
  4661.  
  4662. procedure TDBLookupComboBox.TrackButton(X, Y: Integer);
  4663. var
  4664.   NewState: Boolean;
  4665. begin
  4666.   NewState := PtInRect(Rect(ClientWidth - FButtonWidth, 0, ClientWidth,
  4667.     ClientHeight), Point(X, Y));
  4668.   if FPressed <> NewState then
  4669.   begin
  4670.     FPressed := NewState;
  4671.     Repaint;
  4672.   end;
  4673. end;
  4674.  
  4675. procedure TDBLookupComboBox.CMCancelMode(var Message: TCMCancelMode);
  4676. begin
  4677.   if (Message.Sender <> Self) and (Message.Sender <> FDataList) then
  4678.     CloseUp(False);
  4679. end;
  4680.  
  4681. procedure TDBLookupComboBox.CMCtl3DChanged(var Message: TMessage);
  4682. begin
  4683.   if NewStyleControls then
  4684.   begin
  4685.     RecreateWnd;
  4686.     Height := 0;
  4687.   end;
  4688.   inherited;
  4689. end;
  4690.  
  4691. procedure TDBLookupComboBox.CMFontChanged(var Message: TMessage);
  4692. begin
  4693.   inherited;
  4694.   Height := 0;
  4695. end;
  4696.  
  4697. procedure TDBLookupComboBox.CMGetDataLink(var Message: TMessage);
  4698. begin
  4699.   Message.Result := Integer(FDataLink);
  4700. end;
  4701.  
  4702. procedure TDBLookupComboBox.WMCancelMode(var Message: TMessage);
  4703. begin
  4704.   StopTracking;
  4705.   inherited;
  4706. end;
  4707.  
  4708. procedure TDBLookupComboBox.WMKillFocus(var Message: TWMKillFocus);
  4709. begin
  4710.   inherited;
  4711.   CloseUp(False);
  4712. end;
  4713.  
  4714. { TDBRichEdit }
  4715.  
  4716. constructor TDBRichEdit.Create(AOwner: TComponent);
  4717. begin
  4718.   inherited Create(AOwner);
  4719.   inherited ReadOnly := True;
  4720.   FAutoDisplay := True;
  4721.   FDataLink := TFieldDataLink.Create(Self);
  4722.   FDataLink.OnDataChange := DataChange;
  4723.   FDataLink.OnEditingChange := EditingChange;
  4724.   FDataLink.OnUpdateData := UpdateData;
  4725. end;
  4726.  
  4727. destructor TDBRichEdit.Destroy;
  4728. begin
  4729.   FDataLink.Free;
  4730.   FDataLink := nil;
  4731.   inherited Destroy;
  4732. end;
  4733.  
  4734. procedure TDBRichEdit.Notification(AComponent: TComponent;
  4735.   Operation: TOperation);
  4736. begin
  4737.   inherited Notification(AComponent, Operation);
  4738.   if (Operation = opRemove) and (FDataLink <> nil) and
  4739.     (AComponent = DataSource) then DataSource := nil;
  4740. end;
  4741.  
  4742. procedure TDBRichEdit.BeginEditing;
  4743. begin
  4744.   if not FDataLink.Editing then
  4745.   try
  4746.     if FDataLink.Field.IsBlob then
  4747.       FDataSave := FDataLink.Field.AsString;
  4748.     FDataLink.Edit;
  4749.   finally
  4750.     FDataSave := '';
  4751.   end;
  4752. end;
  4753.  
  4754. procedure TDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState);
  4755. begin
  4756.   inherited KeyDown(Key, Shift);
  4757.   if FMemoLoaded then
  4758.   begin
  4759.     if (Key = VK_DELETE) or (Key = VK_BACK) or
  4760.       ((Key = VK_INSERT) and (ssShift in Shift)) or
  4761.       (((Key = Ord('V')) or (Key = Ord('X'))) and (ssCtrl in Shift)) then
  4762.       BeginEditing;
  4763.   end;
  4764. end;
  4765.  
  4766. procedure TDBRichEdit.KeyPress(var Key: Char);
  4767. begin
  4768.   inherited KeyPress(Key);
  4769.   if FMemoLoaded then
  4770.   begin
  4771.     if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
  4772.       not FDataLink.Field.IsValidChar(Key) then
  4773.     begin
  4774.       MessageBeep(0);
  4775.       Key := #0;
  4776.     end;
  4777.     case Key of
  4778.       ^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
  4779.         BeginEditing;
  4780.       #27:
  4781.         FDataLink.Reset;
  4782.     end;
  4783.   end else
  4784.   begin
  4785.     if Key = #13 then LoadMemo;
  4786.     Key := #0;
  4787.   end;
  4788. end;
  4789.  
  4790. procedure TDBRichEdit.Change;
  4791. begin
  4792.   if FMemoLoaded then FDataLink.Modified;
  4793.   FMemoLoaded := True;
  4794.   inherited Change;
  4795. end;
  4796.  
  4797. function TDBRichEdit.GetDataSource: TDataSource;
  4798. begin
  4799.   Result := FDataLink.DataSource;
  4800. end;
  4801.  
  4802. procedure TDBRichEdit.SetDataSource(Value: TDataSource);
  4803. begin
  4804.   FDataLink.DataSource := Value;
  4805.   if Value <> nil then Value.FreeNotification(Self);
  4806. end;
  4807.  
  4808. function TDBRichEdit.GetDataField: string;
  4809. begin
  4810.   Result := FDataLink.FieldName;
  4811. end;
  4812.  
  4813. procedure TDBRichEdit.SetDataField(const Value: string);
  4814. begin
  4815.   FDataLink.FieldName := Value;
  4816. end;
  4817.  
  4818. function TDBRichEdit.GetReadOnly: Boolean;
  4819. begin
  4820.   Result := FDataLink.ReadOnly;
  4821. end;
  4822.  
  4823. procedure TDBRichEdit.SetReadOnly(Value: Boolean);
  4824. begin
  4825.   FDataLink.ReadOnly := Value;
  4826. end;
  4827.  
  4828. function TDBRichEdit.GetField: TField;
  4829. begin
  4830.   Result := FDataLink.Field;
  4831. end;
  4832.  
  4833. procedure TDBRichEdit.LoadMemo;
  4834. begin
  4835.   if not FMemoLoaded and Assigned(FDataLink.Field) and FDataLink.Field.IsBlob then
  4836.   begin
  4837.     try
  4838.       Lines.Assign(FDataLink.Field);
  4839.       FMemoLoaded := True;
  4840.     except
  4841.       { Rich Edit Load failure }
  4842.       on E:EOutOfResources do
  4843.         Lines.Text := Format('(%s)', [E.Message]);
  4844.     end;
  4845.     EditingChange(Self);
  4846.   end;
  4847. end;
  4848.  
  4849. procedure TDBRichEdit.DataChange(Sender: TObject);
  4850. begin
  4851.   if FDataLink.Field <> nil then
  4852.     if FDataLink.Field.IsBlob then
  4853.     begin
  4854.       if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then
  4855.       begin
  4856.         { Check if the data has changed since we read it the first time }
  4857.         if (FDataSave <> '') and (FDataSave = FDataLink.Field.AsString) then Exit;
  4858.         FMemoLoaded := False;
  4859.         LoadMemo;
  4860.       end else
  4861.       begin
  4862.         Text := Format('(%s)', [FDataLink.Field.DisplayLabel]);
  4863.         FMemoLoaded := False;
  4864.       end;
  4865.     end else
  4866.     begin
  4867.       if FFocused and FDataLink.CanModify then
  4868.         Text := FDataLink.Field.Text
  4869.       else
  4870.         Text := FDataLink.Field.DisplayText;
  4871.       FMemoLoaded := True;
  4872.     end
  4873.   else
  4874.   begin
  4875.     if csDesigning in ComponentState then Text := Name else Text := '';
  4876.     FMemoLoaded := False;
  4877.   end;
  4878.   if HandleAllocated then
  4879.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);
  4880. end;
  4881.  
  4882. procedure TDBRichEdit.EditingChange(Sender: TObject);
  4883. begin
  4884.   inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded);
  4885. end;
  4886.  
  4887. procedure TDBRichEdit.UpdateData(Sender: TObject);
  4888. begin
  4889.   if FDataLink.Field.IsBlob then
  4890.     FDataLink.Field.Assign(Lines) else
  4891.     FDataLink.Field.AsString := Text;
  4892. end;
  4893.  
  4894. procedure TDBRichEdit.SetFocused(Value: Boolean);
  4895. begin
  4896.   if FFocused <> Value then
  4897.   begin
  4898.     FFocused := Value;
  4899.     if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then
  4900.       FDataLink.Reset;
  4901.   end;
  4902. end;
  4903.  
  4904. procedure TDBRichEdit.CMEnter(var Message: TCMEnter);
  4905. begin
  4906.   SetFocused(True);
  4907.   inherited;
  4908. end;
  4909.  
  4910. procedure TDBRichEdit.CMExit(var Message: TCMExit);
  4911. begin
  4912.   try
  4913.     FDataLink.UpdateRecord;
  4914.   except
  4915.     SetFocus;
  4916.     raise;
  4917.   end;
  4918.   SetFocused(False);
  4919.   inherited;
  4920. end;
  4921.  
  4922. procedure TDBRichEdit.SetAutoDisplay(Value: Boolean);
  4923. begin
  4924.   if FAutoDisplay <> Value then
  4925.   begin
  4926.     FAutoDisplay := Value;
  4927.     if Value then LoadMemo;
  4928.   end;
  4929. end;
  4930.  
  4931. procedure TDBRichEdit.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  4932. begin
  4933.   if not FMemoLoaded then LoadMemo else inherited;
  4934. end;
  4935.  
  4936. procedure TDBRichEdit.WMCut(var Message: TMessage);
  4937. begin
  4938.   BeginEditing;
  4939.   inherited;
  4940. end;
  4941.  
  4942. procedure TDBRichEdit.WMPaste(var Message: TMessage);
  4943. begin
  4944.   BeginEditing;
  4945.   inherited;
  4946. end;
  4947.  
  4948. procedure TDBRichEdit.CMGetDataLink(var Message: TMessage);
  4949. begin
  4950.   Message.Result := Integer(FDataLink);
  4951. end;
  4952.  
  4953.  
  4954. end.
  4955.